commit da31815d41e2992f855c24ceaad9e145652d06d0 · anil.recoil.org/slop

+43

yaml/ocaml-yamle/TODO.md

···

       1
       +
       # Yamle Implementation Progress

     

       2
       +
       

     

       3
       +
       ## Phase 1: Foundation

     

       4
       +
       - [x] Project structure and dune files

     

       5
       +
       - [ ] Position module - location tracking

     

       6
       +
       - [ ] Span module - source ranges

     

       7
       +
       - [ ] Error module - exception with position info

     

       8
       +
       - [ ] Encoding module - UTF-8/16 detection

     

       9
       +
       

     

       10
       +
       ## Phase 2: Styles and Input

     

       11
       +
       - [ ] Scalar_style module

     

       12
       +
       - [ ] Layout_style module

     

       13
       +
       - [ ] Chomping module

     

       14
       +
       - [ ] Input module - character source abstraction

     

       15
       +
       

     

       16
       +
       ## Phase 3: Scanner (Lexer)

     

       17
       +
       - [ ] Token module - token types

     

       18
       +
       - [ ] Scanner module - tokenizer with lookahead

     

       19
       +
       

     

       20
       +
       ## Phase 4: Parser

     

       21
       +
       - [ ] Event module - parser events

     

       22
       +
       - [ ] Parser module - state machine

     

       23
       +
       

     

       24
       +
       ## Phase 5: Data Structures

     

       25
       +
       - [ ] Value module - JSON-compatible representation

     

       26
       +
       - [ ] Tag module - YAML tags

     

       27
       +
       - [ ] Scalar module - scalar with metadata

     

       28
       +
       - [ ] Sequence module - sequence with metadata

     

       29
       +
       - [ ] Mapping module - mapping with metadata

     

       30
       +
       - [ ] Yaml module - full YAML representation

     

       31
       +
       - [ ] Document module - document wrapper

     

       32
       +
       

     

       33
       +
       ## Phase 6: Loader and Emitter

     

       34
       +
       - [ ] Loader module - events to data structures

     

       35
       +
       - [ ] Emitter module - data structures to YAML string

     

       36
       +
       

     

       37
       +
       ## Phase 7: Top-Level API

     

       38
       +
       - [ ] Yamle module - main API

     

       39
       +
       - [ ] Stream submodule - streaming interface

     

       40
       +
       

     

       41
       +
       ## Phase 8: Testing

     

       42
       +
       - [ ] Unit tests for each module

     

       43
       +
       - [ ] Integration tests with YAML test suite

yaml/ocaml-yamle/bin/dune

···

       1
       +
       (executable

     

       2
       +
        (name yamlcat)

     

       3
       +
        (public_name yamlcat)

     

       4
       +
        (libraries yamle))

     

       5
       +
       

     

       6
       +
       (executable

     

       7
       +
        (name test_emit)

     

       8
       +
        (libraries yamle))

+14

yaml/ocaml-yamle/bin/test_emit.ml

···

       1
       +
       let () =

     

       2
       +
         let yaml = {|

     

       3
       +
       name: Alice

     

       4
       +
       age: 30

     

       5
       +
       hobbies:

     

       6
       +
         - reading

     

       7
       +
         - coding

     

       8
       +
       |} in

     

       9
       +
         let v = Yamle.of_string yaml in

     

       10
       +
         print_endline "=== Using to_string (YAML output) ===";

     

       11
       +
         print_endline (Yamle.to_string v);

     

       12
       +
         print_endline "";

     

       13
       +
         print_endline "=== Using pp (JSON-like) ===";

     

       14
       +
         Format.printf "%a@." Yamle.pp v

+105

yaml/ocaml-yamle/bin/yamlcat.ml

···

       1
       +
       (** yamlcat - parse and reprint YAML files *)

     

       2
       +
       

     

       3
       +
       let usage () =

     

       4
       +
         Printf.eprintf "Usage: %s [OPTIONS] [FILE...]\n" Sys.argv.(0);

     

       5
       +
         Printf.eprintf "\n";

     

       6
       +
         Printf.eprintf "Parse YAML files and reprint them.\n";

     

       7
       +
         Printf.eprintf "If no files are given, reads from stdin.\n";

     

       8
       +
         Printf.eprintf "\n";

     

       9
       +
         Printf.eprintf "Options:\n";

     

       10
       +
         Printf.eprintf "  --json     Output as JSON format\n";

     

       11
       +
         Printf.eprintf "  --flow     Output YAML in flow style\n";

     

       12
       +
         Printf.eprintf "  --debug    Output internal representation (for debugging)\n";

     

       13
       +
         Printf.eprintf "  --help     Show this help message\n";

     

       14
       +
         exit 1

     

       15
       +
       

     

       16
       +
       type output_format = Yaml | Json | Flow | Debug

     

       17
       +
       

     

       18
       +
       let rec json_to_string buf (v : Yamle.value) =

     

       19
       +
         match v with

     

       20
       +
         | `Null -> Buffer.add_string buf "null"

     

       21
       +
         | `Bool b -> Buffer.add_string buf (if b then "true" else "false")

     

       22
       +
         | `Float f ->

     

       23
       +
             if Float.is_integer f && Float.abs f < 1e15 then

     

       24
       +
               Buffer.add_string buf (Printf.sprintf "%.0f" f)

     

       25
       +
             else

     

       26
       +
               Buffer.add_string buf (Printf.sprintf "%g" f)

     

       27
       +
         | `String s -> Buffer.add_string buf (Printf.sprintf "%S" s)

     

       28
       +
         | `A items ->

     

       29
       +
             Buffer.add_char buf '[';

     

       30
       +
             List.iteri (fun i item ->

     

       31
       +
               if i > 0 then Buffer.add_string buf ", ";

     

       32
       +
               json_to_string buf item

     

       33
       +
             ) items;

     

       34
       +
             Buffer.add_char buf ']'

     

       35
       +
         | `O pairs ->

     

       36
       +
             Buffer.add_char buf '{';

     

       37
       +
             List.iteri (fun i (k, v) ->

     

       38
       +
               if i > 0 then Buffer.add_string buf ", ";

     

       39
       +
               Buffer.add_string buf (Printf.sprintf "%S: " k);

     

       40
       +
               json_to_string buf v

     

       41
       +
             ) pairs;

     

       42
       +
             Buffer.add_char buf '}'

     

       43
       +
       

     

       44
       +
       let value_to_json v =

     

       45
       +
         let buf = Buffer.create 256 in

     

       46
       +
         json_to_string buf v;

     

       47
       +
         Buffer.contents buf

     

       48
       +
       

     

       49
       +
       let process_string ~format content =

     

       50
       +
         try

     

       51
       +
           match format with

     

       52
       +
           | Yaml ->

     

       53
       +
               let value = Yamle.of_string content in

     

       54
       +
               print_string (Yamle.to_string value)

     

       55
       +
           | Flow ->

     

       56
       +
               let value = Yamle.of_string content in

     

       57
       +
               print_string (Yamle.to_string ~layout_style:Yamle.Layout_style.Flow value)

     

       58
       +
           | Json ->

     

       59
       +
               let value = Yamle.of_string content in

     

       60
       +
               print_endline (value_to_json value)

     

       61
       +
           | Debug ->

     

       62
       +
               let yaml = Yamle.yaml_of_string content in

     

       63
       +
               Format.printf "%a@." Yamle.pp_yaml yaml

     

       64
       +
         with

     

       65
       +
         | Yamle.Yamle_error e ->

     

       66
       +
             Printf.eprintf "Error: %s\n" (Yamle.Error.to_string e);

     

       67
       +
             exit 1

     

       68
       +
       

     

       69
       +
       let process_file ~format filename =

     

       70
       +
         let content =

     

       71
       +
           if filename = "-" then

     

       72
       +
             In_channel.input_all In_channel.stdin

     

       73
       +
           else

     

       74
       +
             In_channel.with_open_text filename In_channel.input_all

     

       75
       +
         in

     

       76
       +
         process_string ~format content

     

       77
       +
       

     

       78
       +
       let () =

     

       79
       +
         let files = ref [] in

     

       80
       +
         let format = ref Yaml in

     

       81
       +
         let show_help = ref false in

     

       82
       +
       

     

       83
       +
         (* Parse arguments *)

     

       84
       +
         let args = Array.to_list Sys.argv |> List.tl in

     

       85
       +
         List.iter (fun arg ->

     

       86
       +
           match arg with

     

       87
       +
           | "--help" | "-h" -> show_help := true

     

       88
       +
           | "--json" -> format := Json

     

       89
       +
           | "--flow" -> format := Flow

     

       90
       +
           | "--debug" -> format := Debug

     

       91
       +
           | s when String.length s > 0 && s.[0] = '-' ->

     

       92
       +
               Printf.eprintf "Unknown option: %s\n" s;

     

       93
       +
               usage ()

     

       94
       +
           | filename -> files := filename :: !files

     

       95
       +
         ) args;

     

       96
       +
       

     

       97
       +
         if !show_help then usage ();

     

       98
       +
       

     

       99
       +
         let files = List.rev !files in

     

       100
       +
       

     

       101
       +
         if files = [] then

     

       102
       +
           (* Read from stdin *)

     

       103
       +
           process_file ~format:!format "-"

     

       104
       +
         else

     

       105
       +
           List.iter (process_file ~format:!format) files

+19

yaml/ocaml-yamle/dune-project

···

       1
       +
       (lang dune 3.0)

     

       2
       +
       (name yamle)

     

       3
       +
       (version 0.1.0)

     

       4
       +
       

     

       5
       +
       (generate_opam_files true)

     

       6
       +
       

     

       7
       +
       (source (github ocaml/yamle))

     

       8
       +
       (license ISC)

     

       9
       +
       (authors "Yamle Authors")

     

       10
       +
       (maintainers "yamle@example.com")

     

       11
       +
       

     

       12
       +
       (package

     

       13
       +
        (name yamle)

     

       14
       +
        (synopsis "Pure OCaml YAML 1.2 parser and emitter")

     

       15
       +
        (description "A pure OCaml implementation of YAML 1.2 parsing and emission, with no C dependencies.")

     

       16
       +
        (depends

     

       17
       +
         (ocaml (>= 4.14.0))

     

       18
       +
         (dune (>= 3.0))

     

       19
       +
         (alcotest :with-test)))

+26

yaml/ocaml-yamle/lib/chomping.ml

···

       1
       +
       (** Block scalar chomping indicators *)

     

       2
       +
       

     

       3
       +
       type t =

     

       4
       +
         | Strip (** Remove final line break and trailing empty lines *)

     

       5
       +
         | Clip  (** Keep final line break, remove trailing empty lines (default) *)

     

       6
       +
         | Keep  (** Keep final line break and trailing empty lines *)

     

       7
       +
       

     

       8
       +
       let to_string = function

     

       9
       +
         | Strip -> "strip"

     

       10
       +
         | Clip -> "clip"

     

       11
       +
         | Keep -> "keep"

     

       12
       +
       

     

       13
       +
       let pp fmt t =

     

       14
       +
         Format.pp_print_string fmt (to_string t)

     

       15
       +
       

     

       16
       +
       let of_char = function

     

       17
       +
         | '-' -> Some Strip

     

       18
       +
         | '+' -> Some Keep

     

       19
       +
         | _ -> None

     

       20
       +
       

     

       21
       +
       let to_char = function

     

       22
       +
         | Strip -> Some '-'

     

       23
       +
         | Clip -> None

     

       24
       +
         | Keep -> Some '+'

     

       25
       +
       

     

       26
       +
       let equal a b = a = b

+54

yaml/ocaml-yamle/lib/document.ml

···

       1
       +
       (** YAML document with directives and content *)

     

       2
       +
       

     

       3
       +
       type t = {

     

       4
       +
         version : (int * int) option;

     

       5
       +
         tags : (string * string) list;

     

       6
       +
         root : Yaml.t option;

     

       7
       +
         implicit_start : bool;

     

       8
       +
         implicit_end : bool;

     

       9
       +
       }

     

       10
       +
       

     

       11
       +
       let make

     

       12
       +
           ?(version : (int * int) option)

     

       13
       +
           ?(tags : (string * string) list = [])

     

       14
       +
           ?(implicit_start = true)

     

       15
       +
           ?(implicit_end = true)

     

       16
       +
           root =

     

       17
       +
         { version; tags; root; implicit_start; implicit_end }

     

       18
       +
       

     

       19
       +
       let version t = t.version

     

       20
       +
       let tags t = t.tags

     

       21
       +
       let root t = t.root

     

       22
       +
       let implicit_start t = t.implicit_start

     

       23
       +
       let implicit_end t = t.implicit_end

     

       24
       +
       

     

       25
       +
       let with_version version t = { t with version = Some version }

     

       26
       +
       let with_tags tags t = { t with tags }

     

       27
       +
       let with_root root t = { t with root = Some root }

     

       28
       +
       

     

       29
       +
       let pp fmt t =

     

       30
       +
         Format.fprintf fmt "@[<v 2>document(@,";

     

       31
       +
         (match t.version with

     

       32
       +
          | Some (maj, min) -> Format.fprintf fmt "version=%d.%d,@ " maj min

     

       33
       +
          | None -> ());

     

       34
       +
         if t.tags <> [] then begin

     

       35
       +
           Format.fprintf fmt "tags=[";

     

       36
       +
           List.iteri (fun i (h, p) ->

     

       37
       +
             if i > 0 then Format.fprintf fmt ", ";

     

       38
       +
             Format.fprintf fmt "%s -> %s" h p

     

       39
       +
           ) t.tags;

     

       40
       +
           Format.fprintf fmt "],@ "

     

       41
       +
         end;

     

       42
       +
         Format.fprintf fmt "implicit_start=%b,@ " t.implicit_start;

     

       43
       +
         Format.fprintf fmt "implicit_end=%b,@ " t.implicit_end;

     

       44
       +
         (match t.root with

     

       45
       +
          | Some root -> Format.fprintf fmt "root=%a" Yaml.pp root

     

       46
       +
          | None -> Format.fprintf fmt "root=<empty>");

     

       47
       +
         Format.fprintf fmt "@]@,)"

     

       48
       +
       

     

       49
       +
       let equal a b =

     

       50
       +
         Option.equal (fun (a1, a2) (b1, b2) -> a1 = b1 && a2 = b2) a.version b.version &&

     

       51
       +
         List.equal (fun (h1, p1) (h2, p2) -> h1 = h2 && p1 = p2) a.tags b.tags &&

     

       52
       +
         Option.equal Yaml.equal a.root b.root &&

     

       53
       +
         a.implicit_start = b.implicit_start &&

     

       54
       +
         a.implicit_end = b.implicit_end

+26

yaml/ocaml-yamle/lib/dune

···

       1
       +
       (library

     

       2
       +
        (name yamle)

     

       3
       +
        (public_name yamle)

     

       4
       +
        (modules

     

       5
       +
         position

     

       6
       +
         span

     

       7
       +
         error

     

       8
       +
         encoding

     

       9
       +
         scalar_style

     

       10
       +
         layout_style

     

       11
       +
         chomping

     

       12
       +
         input

     

       13
       +
         token

     

       14
       +
         scanner

     

       15
       +
         event

     

       16
       +
         parser

     

       17
       +
         value

     

       18
       +
         tag

     

       19
       +
         scalar

     

       20
       +
         sequence

     

       21
       +
         mapping

     

       22
       +
         yaml

     

       23
       +
         document

     

       24
       +
         loader

     

       25
       +
         emitter

     

       26
       +
         yamle))

+701

yaml/ocaml-yamle/lib/emitter.ml

···

       1
       +
       (** Emitter - converts YAML data structures to string output *)

     

       2
       +
       

     

       3
       +
       type config = {

     

       4
       +
         encoding : Encoding.t;

     

       5
       +
         scalar_style : Scalar_style.t;

     

       6
       +
         layout_style : Layout_style.t;

     

       7
       +
         indent : int;

     

       8
       +
         width : int;

     

       9
       +
         canonical : bool;

     

       10
       +
       }

     

       11
       +
       

     

       12
       +
       let default_config = {

     

       13
       +
         encoding = Encoding.Utf8;

     

       14
       +
         scalar_style = Scalar_style.Any;

     

       15
       +
         layout_style = Layout_style.Any;

     

       16
       +
         indent = 2;

     

       17
       +
         width = 80;

     

       18
       +
         canonical = false;

     

       19
       +
       }

     

       20
       +
       

     

       21
       +
       type state =

     

       22
       +
         | Initial

     

       23
       +
         | Stream_started

     

       24
       +
         | Document_started

     

       25
       +
         | In_block_sequence of int  (* indent level *)

     

       26
       +
         | In_block_mapping_key of int

     

       27
       +
         | In_block_mapping_value of int

     

       28
       +
         | In_block_mapping_first_key of int  (* first key after "- ", no indent needed *)

     

       29
       +
         | In_flow_sequence

     

       30
       +
         | In_flow_mapping_key

     

       31
       +
         | In_flow_mapping_value

     

       32
       +
         | Document_ended

     

       33
       +
         | Stream_ended

     

       34
       +
       

     

       35
       +
       type t = {

     

       36
       +
         config : config;

     

       37
       +
         buffer : Buffer.t;

     

       38
       +
         mutable state : state;

     

       39
       +
         mutable states : state list;

     

       40
       +
         mutable indent : int;

     

       41
       +
         mutable flow_level : int;

     

       42
       +
         mutable need_separator : bool;

     

       43
       +
       }

     

       44
       +
       

     

       45
       +
       let create ?(config = default_config) () = {

     

       46
       +
         config;

     

       47
       +
         buffer = Buffer.create 1024;

     

       48
       +
         state = Initial;

     

       49
       +
         states = [];

     

       50
       +
         indent = 0;

     

       51
       +
         flow_level = 0;

     

       52
       +
         need_separator = false;

     

       53
       +
       }

     

       54
       +
       

     

       55
       +
       let contents t = Buffer.contents t.buffer

     

       56
       +
       

     

       57
       +
       let reset t =

     

       58
       +
         Buffer.clear t.buffer;

     

       59
       +
         t.state <- Initial;

     

       60
       +
         t.states <- [];

     

       61
       +
         t.indent <- 0;

     

       62
       +
         t.flow_level <- 0;

     

       63
       +
         t.need_separator <- false

     

       64
       +
       

     

       65
       +
       (** Output helpers *)

     

       66
       +
       

     

       67
       +
       let write t s = Buffer.add_string t.buffer s

     

       68
       +
       let write_char t c = Buffer.add_char t.buffer c

     

       69
       +
       

     

       70
       +
       let write_indent t =

     

       71
       +
         for _ = 1 to t.indent do

     

       72
       +
           write_char t ' '

     

       73
       +
         done

     

       74
       +
       

     

       75
       +
       let write_newline t =

     

       76
       +
         write_char t '\n'

     

       77
       +
       

     

       78
       +
       let push_state t s =

     

       79
       +
         t.states <- t.state :: t.states;

     

       80
       +
         t.state <- s

     

       81
       +
       

     

       82
       +
       let pop_state t =

     

       83
       +
         match t.states with

     

       84
       +
         | s :: rest ->

     

       85
       +
             t.state <- s;

     

       86
       +
             t.states <- rest

     

       87
       +
         | [] ->

     

       88
       +
             t.state <- Stream_ended

     

       89
       +
       

     

       90
       +
       (** Check if string needs quoting *)

     

       91
       +
       let needs_quoting s =

     

       92
       +
         if String.length s = 0 then true

     

       93
       +
         else

     

       94
       +
           let first = s.[0] in

     

       95
       +
           (* Check first character *)

     

       96
       +
           if first = '-' || first = '?' || first = ':' || first = ',' ||

     

       97
       +
              first = '[' || first = ']' || first = '{' || first = '}' ||

     

       98
       +
              first = '#' || first = '&' || first = '*' || first = '!' ||

     

       99
       +
              first = '|' || first = '>' || first = '\'' || first = '"' ||

     

       100
       +
              first = '%' || first = '@' || first = '`' || first = ' ' then

     

       101
       +
             true

     

       102
       +
           else

     

       103
       +
             (* Check for special values *)

     

       104
       +
             let lower = String.lowercase_ascii s in

     

       105
       +
             if lower = "null" || lower = "true" || lower = "false" ||

     

       106
       +
                lower = "yes" || lower = "no" || lower = "on" || lower = "off" ||

     

       107
       +
                lower = "~" || lower = ".inf" || lower = "-.inf" || lower = ".nan" then

     

       108
       +
               true

     

       109
       +
             else

     

       110
       +
               (* Check for characters that need quoting *)

     

       111
       +
               try

     

       112
       +
                 String.iter (fun c ->

     

       113
       +
                   if c = ':' || c = '#' || c = '\n' || c = '\r' then

     

       114
       +
                     raise Exit

     

       115
       +
                 ) s;

     

       116
       +
                 (* Check if it looks like a number *)

     

       117
       +
                 (try ignore (Float.of_string s); true with _ -> false)

     

       118
       +
               with Exit -> true

     

       119
       +
       

     

       120
       +
       (** Check if string contains characters requiring double quotes *)

     

       121
       +
       let needs_double_quotes s =

     

       122
       +
         try

     

       123
       +
           String.iter (fun c ->

     

       124
       +
             if c = '\n' || c = '\r' || c = '\t' || c = '\\' ||

     

       125
       +
                c < ' ' || c = '"' then

     

       126
       +
               raise Exit

     

       127
       +
           ) s;

     

       128
       +
           false

     

       129
       +
         with Exit -> true

     

       130
       +
       

     

       131
       +
       (** Write scalar with appropriate quoting *)

     

       132
       +
       let write_scalar t ?(style = Scalar_style.Any) value =

     

       133
       +
         let effective_style =

     

       134
       +
           if style = Scalar_style.Any then

     

       135
       +
             if needs_double_quotes value then Scalar_style.Double_quoted

     

       136
       +
             else if needs_quoting value then Scalar_style.Single_quoted

     

       137
       +
             else Scalar_style.Plain

     

       138
       +
           else style

     

       139
       +
         in

     

       140
       +
         match effective_style with

     

       141
       +
         | Scalar_style.Plain | Scalar_style.Any ->

     

       142
       +
             write t value

     

       143
       +
       

     

       144
       +
         | Scalar_style.Single_quoted ->

     

       145
       +
             write_char t '\'';

     

       146
       +
             String.iter (fun c ->

     

       147
       +
               if c = '\'' then write t "''"

     

       148
       +
               else write_char t c

     

       149
       +
             ) value;

     

       150
       +
             write_char t '\''

     

       151
       +
       

     

       152
       +
         | Scalar_style.Double_quoted ->

     

       153
       +
             write_char t '"';

     

       154
       +
             String.iter (fun c ->

     

       155
       +
               match c with

     

       156
       +
               | '"' -> write t "\\\""

     

       157
       +
               | '\\' -> write t "\\\\"

     

       158
       +
               | '\n' -> write t "\\n"

     

       159
       +
               | '\r' -> write t "\\r"

     

       160
       +
               | '\t' -> write t "\\t"

     

       161
       +
               | c when c < ' ' -> write t (Printf.sprintf "\\x%02x" (Char.code c))

     

       162
       +
               | c -> write_char t c

     

       163
       +
             ) value;

     

       164
       +
             write_char t '"'

     

       165
       +
       

     

       166
       +
         | Scalar_style.Literal ->

     

       167
       +
             write t "|";

     

       168
       +
             write_newline t;

     

       169
       +
             let lines = String.split_on_char '\n' value in

     

       170
       +
             List.iter (fun line ->

     

       171
       +
               write_indent t;

     

       172
       +
               write t line;

     

       173
       +
               write_newline t

     

       174
       +
             ) lines

     

       175
       +
       

     

       176
       +
         | Scalar_style.Folded ->

     

       177
       +
             write t ">";

     

       178
       +
             write_newline t;

     

       179
       +
             let lines = String.split_on_char '\n' value in

     

       180
       +
             List.iter (fun line ->

     

       181
       +
               write_indent t;

     

       182
       +
               write t line;

     

       183
       +
               write_newline t

     

       184
       +
             ) lines

     

       185
       +
       

     

       186
       +
       (** Write anchor if present *)

     

       187
       +
       let write_anchor t anchor =

     

       188
       +
         match anchor with

     

       189
       +
         | Some name ->

     

       190
       +
             write_char t '&';

     

       191
       +
             write t name;

     

       192
       +
             write_char t ' '

     

       193
       +
         | None -> ()

     

       194
       +
       

     

       195
       +
       (** Write tag if present and not implicit *)

     

       196
       +
       let write_tag t ~implicit tag =

     

       197
       +
         if not implicit then

     

       198
       +
           match tag with

     

       199
       +
           | Some tag_str ->

     

       200
       +
               write_char t '!';

     

       201
       +
               write t tag_str;

     

       202
       +
               write_char t ' '

     

       203
       +
           | None -> ()

     

       204
       +
       

     

       205
       +
       (** Emit events *)

     

       206
       +
       

     

       207
       +
       let emit t (ev : Event.t) =

     

       208
       +
         match ev with

     

       209
       +
         | Event.Stream_start _ ->

     

       210
       +
             t.state <- Stream_started

     

       211
       +
       

     

       212
       +
         | Event.Stream_end ->

     

       213
       +
             t.state <- Stream_ended

     

       214
       +
       

     

       215
       +
         | Event.Document_start { version; implicit } ->

     

       216
       +
             if not implicit then begin

     

       217
       +
               (match version with

     

       218
       +
                | Some (maj, min) ->

     

       219
       +
                    write t (Printf.sprintf "%%YAML %d.%d\n" maj min)

     

       220
       +
                | None -> ());

     

       221
       +
               write t "---";

     

       222
       +
               write_newline t

     

       223
       +
             end;

     

       224
       +
             t.state <- Document_started

     

       225
       +
       

     

       226
       +
         | Event.Document_end { implicit } ->

     

       227
       +
             if not implicit then begin

     

       228
       +
               write t "...";

     

       229
       +
               write_newline t

     

       230
       +
             end;

     

       231
       +
             t.state <- Document_ended

     

       232
       +
       

     

       233
       +
         | Event.Alias { anchor } ->

     

       234
       +
             if t.flow_level > 0 then begin

     

       235
       +
               if t.need_separator then write t ", ";

     

       236
       +
               t.need_separator <- true;

     

       237
       +
               write_char t '*';

     

       238
       +
               write t anchor

     

       239
       +
             end else begin

     

       240
       +
               (match t.state with

     

       241
       +
                | In_block_sequence _ ->

     

       242
       +
                    write_indent t;

     

       243
       +
                    write t "- *";

     

       244
       +
                    write t anchor;

     

       245
       +
                    write_newline t

     

       246
       +
                | In_block_mapping_key _ ->

     

       247
       +
                    write_indent t;

     

       248
       +
                    write_char t '*';

     

       249
       +
                    write t anchor;

     

       250
       +
                    write t ": ";

     

       251
       +
                    t.state <- In_block_mapping_value t.indent

     

       252
       +
                | In_block_mapping_value indent ->

     

       253
       +
                    write_char t '*';

     

       254
       +
                    write t anchor;

     

       255
       +
                    write_newline t;

     

       256
       +
                    t.state <- In_block_mapping_key indent

     

       257
       +
                | _ ->

     

       258
       +
                    write_char t '*';

     

       259
       +
                    write t anchor;

     

       260
       +
                    write_newline t)

     

       261
       +
             end

     

       262
       +
       

     

       263
       +
         | Event.Scalar { anchor; tag; value; plain_implicit; style; _ } ->

     

       264
       +
             if t.flow_level > 0 then begin

     

       265
       +
               (match t.state with

     

       266
       +
                | In_flow_mapping_key ->

     

       267
       +
                    if t.need_separator then write t ", ";

     

       268
       +
                    write_anchor t anchor;

     

       269
       +
                    write_tag t ~implicit:plain_implicit tag;

     

       270
       +
                    write_scalar t ~style value;

     

       271
       +
                    write t ": ";

     

       272
       +
                    t.need_separator <- false;

     

       273
       +
                    t.state <- In_flow_mapping_value

     

       274
       +
                | In_flow_mapping_value ->

     

       275
       +
                    write_anchor t anchor;

     

       276
       +
                    write_tag t ~implicit:plain_implicit tag;

     

       277
       +
                    write_scalar t ~style value;

     

       278
       +
                    t.need_separator <- true;

     

       279
       +
                    t.state <- In_flow_mapping_key

     

       280
       +
                | _ ->

     

       281
       +
                    if t.need_separator then write t ", ";

     

       282
       +
                    t.need_separator <- true;

     

       283
       +
                    write_anchor t anchor;

     

       284
       +
                    write_tag t ~implicit:plain_implicit tag;

     

       285
       +
                    write_scalar t ~style value)

     

       286
       +
             end else begin

     

       287
       +
               match t.state with

     

       288
       +
               | In_block_sequence _ ->

     

       289
       +
                   write_indent t;

     

       290
       +
                   write t "- ";

     

       291
       +
                   write_anchor t anchor;

     

       292
       +
                   write_tag t ~implicit:plain_implicit tag;

     

       293
       +
                   write_scalar t ~style value;

     

       294
       +
                   write_newline t

     

       295
       +
               | In_block_mapping_key indent ->

     

       296
       +
                   write_indent t;

     

       297
       +
                   write_anchor t anchor;

     

       298
       +
                   write_tag t ~implicit:plain_implicit tag;

     

       299
       +
                   write_scalar t ~style value;

     

       300
       +
                   write_char t ':';

     

       301
       +
                   t.state <- In_block_mapping_value indent

     

       302
       +
               | In_block_mapping_first_key indent ->

     

       303
       +
                   (* First key after "- ", no indent needed *)

     

       304
       +
                   write_anchor t anchor;

     

       305
       +
                   write_tag t ~implicit:plain_implicit tag;

     

       306
       +
                   write_scalar t ~style value;

     

       307
       +
                   write_char t ':';

     

       308
       +
                   t.state <- In_block_mapping_value indent

     

       309
       +
               | In_block_mapping_value indent ->

     

       310
       +
                   write_char t ' ';

     

       311
       +
                   write_anchor t anchor;

     

       312
       +
                   write_tag t ~implicit:plain_implicit tag;

     

       313
       +
                   write_scalar t ~style value;

     

       314
       +
                   write_newline t;

     

       315
       +
                   t.state <- In_block_mapping_key indent

     

       316
       +
               | _ ->

     

       317
       +
                   write_anchor t anchor;

     

       318
       +
                   write_tag t ~implicit:plain_implicit tag;

     

       319
       +
                   write_scalar t ~style value;

     

       320
       +
                   write_newline t

     

       321
       +
             end

     

       322
       +
       

     

       323
       +
         | Event.Sequence_start { anchor; tag; implicit; style } ->

     

       324
       +
             let use_flow = style = Layout_style.Flow || t.flow_level > 0 in

     

       325
       +
             if t.flow_level > 0 then begin

     

       326
       +
               (match t.state with

     

       327
       +
                | In_flow_mapping_key ->

     

       328
       +
                    if t.need_separator then write t ", ";

     

       329
       +
                    write_anchor t anchor;

     

       330
       +
                    write_tag t ~implicit tag;

     

       331
       +
                    write_char t '[';

     

       332
       +
                    t.flow_level <- t.flow_level + 1;

     

       333
       +
                    t.need_separator <- false;

     

       334
       +
                    push_state t In_flow_mapping_value;  (* After ] we'll be in value position but sequence handles it *)

     

       335
       +
                    t.state <- In_flow_sequence

     

       336
       +
                | In_flow_mapping_value ->

     

       337
       +
                    write_anchor t anchor;

     

       338
       +
                    write_tag t ~implicit tag;

     

       339
       +
                    write_char t '[';

     

       340
       +
                    t.flow_level <- t.flow_level + 1;

     

       341
       +
                    t.need_separator <- false;

     

       342
       +
                    push_state t In_flow_mapping_key;

     

       343
       +
                    t.state <- In_flow_sequence

     

       344
       +
                | _ ->

     

       345
       +
                    if t.need_separator then write t ", ";

     

       346
       +
                    write_anchor t anchor;

     

       347
       +
                    write_tag t ~implicit tag;

     

       348
       +
                    write_char t '[';

     

       349
       +
                    t.flow_level <- t.flow_level + 1;

     

       350
       +
                    t.need_separator <- false;

     

       351
       +
                    push_state t In_flow_sequence)

     

       352
       +
             end else begin

     

       353
       +
               match t.state with

     

       354
       +
               | In_block_sequence _ ->

     

       355
       +
                   write_indent t;

     

       356
       +
                   write t "- ";

     

       357
       +
                   write_anchor t anchor;

     

       358
       +
                   write_tag t ~implicit tag;

     

       359
       +
                   if use_flow then begin

     

       360
       +
                     write_char t '[';

     

       361
       +
                     t.flow_level <- t.flow_level + 1;

     

       362
       +
                     t.need_separator <- false;

     

       363
       +
                     push_state t In_flow_sequence

     

       364
       +
                   end else begin

     

       365
       +
                     write_newline t;

     

       366
       +
                     push_state t (In_block_sequence t.indent);

     

       367
       +
                     t.indent <- t.indent + t.config.indent

     

       368
       +
                   end

     

       369
       +
               | In_block_mapping_key indent ->

     

       370
       +
                   write_indent t;

     

       371
       +
                   write_anchor t anchor;

     

       372
       +
                   write_tag t ~implicit tag;

     

       373
       +
                   write t ":";

     

       374
       +
                   write_newline t;

     

       375
       +
                   push_state t (In_block_mapping_key indent);

     

       376
       +
                   t.indent <- t.indent + t.config.indent;

     

       377
       +
                   t.state <- In_block_sequence t.indent

     

       378
       +
               | In_block_mapping_first_key indent ->

     

       379
       +
                   (* First key after "- " with sequence value - no indent *)

     

       380
       +
                   write_anchor t anchor;

     

       381
       +
                   write_tag t ~implicit tag;

     

       382
       +
                   write t ":";

     

       383
       +
                   write_newline t;

     

       384
       +
                   push_state t (In_block_mapping_key indent);

     

       385
       +
                   t.indent <- t.indent + t.config.indent;

     

       386
       +
                   t.state <- In_block_sequence t.indent

     

       387
       +
               | In_block_mapping_value indent ->

     

       388
       +
                   write_anchor t anchor;

     

       389
       +
                   write_tag t ~implicit tag;

     

       390
       +
                   if use_flow then begin

     

       391
       +
                     write_char t '[';

     

       392
       +
                     t.flow_level <- t.flow_level + 1;

     

       393
       +
                     t.need_separator <- false;

     

       394
       +
                     (* Save key state to return to after flow sequence *)

     

       395
       +
                     t.state <- In_block_mapping_key indent;

     

       396
       +
                     push_state t In_flow_sequence

     

       397
       +
                   end else begin

     

       398
       +
                     write_newline t;

     

       399
       +
                     (* Save key state to return to after nested sequence *)

     

       400
       +
                     t.state <- In_block_mapping_key indent;

     

       401
       +
                     push_state t (In_block_sequence (t.indent + t.config.indent));

     

       402
       +
                     t.indent <- t.indent + t.config.indent

     

       403
       +
                   end

     

       404
       +
               | _ ->

     

       405
       +
                   write_anchor t anchor;

     

       406
       +
                   write_tag t ~implicit tag;

     

       407
       +
                   if use_flow then begin

     

       408
       +
                     write_char t '[';

     

       409
       +
                     t.flow_level <- t.flow_level + 1;

     

       410
       +
                     t.need_separator <- false;

     

       411
       +
                     push_state t In_flow_sequence

     

       412
       +
                   end else begin

     

       413
       +
                     push_state t (In_block_sequence t.indent);

     

       414
       +
                     t.state <- In_block_sequence t.indent

     

       415
       +
                   end

     

       416
       +
             end

     

       417
       +
       

     

       418
       +
         | Event.Sequence_end ->

     

       419
       +
             if t.flow_level > 0 then begin

     

       420
       +
               write_char t ']';

     

       421
       +
               t.flow_level <- t.flow_level - 1;

     

       422
       +
               t.need_separator <- true;

     

       423
       +
               pop_state t

     

       424
       +
             end else begin

     

       425
       +
               t.indent <- t.indent - t.config.indent;

     

       426
       +
               pop_state t

     

       427
       +
             end

     

       428
       +
       

     

       429
       +
         | Event.Mapping_start { anchor; tag; implicit; style } ->

     

       430
       +
             let use_flow = style = Layout_style.Flow || t.flow_level > 0 in

     

       431
       +
             if t.flow_level > 0 then begin

     

       432
       +
               (match t.state with

     

       433
       +
                | In_flow_mapping_key ->

     

       434
       +
                    if t.need_separator then write t ", ";

     

       435
       +
                    write_anchor t anchor;

     

       436
       +
                    write_tag t ~implicit tag;

     

       437
       +
                    write_char t '{';

     

       438
       +
                    t.flow_level <- t.flow_level + 1;

     

       439
       +
                    t.need_separator <- false;

     

       440
       +
                    push_state t In_flow_mapping_value;

     

       441
       +
                    t.state <- In_flow_mapping_key

     

       442
       +
                | In_flow_mapping_value ->

     

       443
       +
                    write_anchor t anchor;

     

       444
       +
                    write_tag t ~implicit tag;

     

       445
       +
                    write_char t '{';

     

       446
       +
                    t.flow_level <- t.flow_level + 1;

     

       447
       +
                    t.need_separator <- false;

     

       448
       +
                    push_state t In_flow_mapping_key;

     

       449
       +
                    t.state <- In_flow_mapping_key

     

       450
       +
                | _ ->

     

       451
       +
                    if t.need_separator then write t ", ";

     

       452
       +
                    write_anchor t anchor;

     

       453
       +
                    write_tag t ~implicit tag;

     

       454
       +
                    write_char t '{';

     

       455
       +
                    t.flow_level <- t.flow_level + 1;

     

       456
       +
                    t.need_separator <- false;

     

       457
       +
                    push_state t In_flow_mapping_key)

     

       458
       +
             end else begin

     

       459
       +
               match t.state with

     

       460
       +
               | In_block_sequence _ ->

     

       461
       +
                   write_indent t;

     

       462
       +
                   write t "- ";

     

       463
       +
                   write_anchor t anchor;

     

       464
       +
                   write_tag t ~implicit tag;

     

       465
       +
                   if use_flow then begin

     

       466
       +
                     write_char t '{';

     

       467
       +
                     t.flow_level <- t.flow_level + 1;

     

       468
       +
                     t.need_separator <- false;

     

       469
       +
                     push_state t In_flow_mapping_key

     

       470
       +
                   end else begin

     

       471
       +
                     (* Don't write newline - first key goes on same line as "- " *)

     

       472
       +
                     push_state t (In_block_sequence t.indent);

     

       473
       +
                     t.indent <- t.indent + t.config.indent;

     

       474
       +
                     t.state <- In_block_mapping_first_key t.indent

     

       475
       +
                   end

     

       476
       +
               | In_block_mapping_key indent ->

     

       477
       +
                   write_indent t;

     

       478
       +
                   write_anchor t anchor;

     

       479
       +
                   write_tag t ~implicit tag;

     

       480
       +
                   write t ":";

     

       481
       +
                   write_newline t;

     

       482
       +
                   push_state t (In_block_mapping_key indent);

     

       483
       +
                   t.indent <- t.indent + t.config.indent;

     

       484
       +
                   t.state <- In_block_mapping_key t.indent

     

       485
       +
               | In_block_mapping_first_key indent ->

     

       486
       +
                   (* First key after "- " with mapping value - no indent *)

     

       487
       +
                   write_anchor t anchor;

     

       488
       +
                   write_tag t ~implicit tag;

     

       489
       +
                   write t ":";

     

       490
       +
                   write_newline t;

     

       491
       +
                   push_state t (In_block_mapping_key indent);

     

       492
       +
                   t.indent <- t.indent + t.config.indent;

     

       493
       +
                   t.state <- In_block_mapping_key t.indent

     

       494
       +
               | In_block_mapping_value indent ->

     

       495
       +
                   write_anchor t anchor;

     

       496
       +
                   write_tag t ~implicit tag;

     

       497
       +
                   if use_flow then begin

     

       498
       +
                     write_char t '{';

     

       499
       +
                     t.flow_level <- t.flow_level + 1;

     

       500
       +
                     t.need_separator <- false;

     

       501
       +
                     (* Save key state to return to after flow mapping *)

     

       502
       +
                     t.state <- In_block_mapping_key indent;

     

       503
       +
                     push_state t In_flow_mapping_key

     

       504
       +
                   end else begin

     

       505
       +
                     write_newline t;

     

       506
       +
                     (* Save key state to return to after nested mapping *)

     

       507
       +
                     t.state <- In_block_mapping_key indent;

     

       508
       +
                     push_state t (In_block_mapping_key (t.indent + t.config.indent));

     

       509
       +
                     t.indent <- t.indent + t.config.indent

     

       510
       +
                   end

     

       511
       +
               | _ ->

     

       512
       +
                   write_anchor t anchor;

     

       513
       +
                   write_tag t ~implicit tag;

     

       514
       +
                   if use_flow then begin

     

       515
       +
                     write_char t '{';

     

       516
       +
                     t.flow_level <- t.flow_level + 1;

     

       517
       +
                     t.need_separator <- false;

     

       518
       +
                     push_state t In_flow_mapping_key

     

       519
       +
                   end else begin

     

       520
       +
                     push_state t (In_block_mapping_key t.indent);

     

       521
       +
                     t.state <- In_block_mapping_key t.indent

     

       522
       +
                   end

     

       523
       +
             end

     

       524
       +
       

     

       525
       +
         | Event.Mapping_end ->

     

       526
       +
             if t.flow_level > 0 then begin

     

       527
       +
               write_char t '}';

     

       528
       +
               t.flow_level <- t.flow_level - 1;

     

       529
       +
               t.need_separator <- true;

     

       530
       +
               pop_state t

     

       531
       +
             end else begin

     

       532
       +
               t.indent <- t.indent - t.config.indent;

     

       533
       +
               pop_state t

     

       534
       +
             end

     

       535
       +
       

     

       536
       +
       (** High-level emission *)

     

       537
       +
       

     

       538
       +
       let rec emit_yaml_node t (yaml : Yaml.t) =

     

       539
       +
         match yaml with

     

       540
       +
         | `Scalar s ->

     

       541
       +
             emit t (Event.Scalar {

     

       542
       +
               anchor = Scalar.anchor s;

     

       543
       +
               tag = Scalar.tag s;

     

       544
       +
               value = Scalar.value s;

     

       545
       +
               plain_implicit = Scalar.plain_implicit s;

     

       546
       +
               quoted_implicit = Scalar.quoted_implicit s;

     

       547
       +
               style = Scalar.style s;

     

       548
       +
             })

     

       549
       +
       

     

       550
       +
         | `Alias name ->

     

       551
       +
             emit t (Event.Alias { anchor = name })

     

       552
       +
       

     

       553
       +
         | `A seq ->

     

       554
       +
             emit t (Event.Sequence_start {

     

       555
       +
               anchor = Sequence.anchor seq;

     

       556
       +
               tag = Sequence.tag seq;

     

       557
       +
               implicit = Sequence.implicit seq;

     

       558
       +
               style = Sequence.style seq;

     

       559
       +
             });

     

       560
       +
             List.iter (emit_yaml_node t) (Sequence.members seq);

     

       561
       +
             emit t Event.Sequence_end

     

       562
       +
       

     

       563
       +
         | `O map ->

     

       564
       +
             emit t (Event.Mapping_start {

     

       565
       +
               anchor = Mapping.anchor map;

     

       566
       +
               tag = Mapping.tag map;

     

       567
       +
               implicit = Mapping.implicit map;

     

       568
       +
               style = Mapping.style map;

     

       569
       +
             });

     

       570
       +
             List.iter (fun (k, v) ->

     

       571
       +
               emit_yaml_node t k;

     

       572
       +
               emit_yaml_node t v

     

       573
       +
             ) (Mapping.members map);

     

       574
       +
             emit t Event.Mapping_end

     

       575
       +
       

     

       576
       +
       let emit_yaml t yaml =

     

       577
       +
         emit t (Event.Stream_start { encoding = t.config.encoding });

     

       578
       +
         emit t (Event.Document_start { version = None; implicit = true });

     

       579
       +
         emit_yaml_node t yaml;

     

       580
       +
         emit t (Event.Document_end { implicit = true });

     

       581
       +
         emit t Event.Stream_end

     

       582
       +
       

     

       583
       +
       let rec emit_value_node t (value : Value.t) =

     

       584
       +
         match value with

     

       585
       +
         | `Null ->

     

       586
       +
             emit t (Event.Scalar {

     

       587
       +
               anchor = None; tag = None;

     

       588
       +
               value = "null";

     

       589
       +
               plain_implicit = true; quoted_implicit = false;

     

       590
       +
               style = Scalar_style.Plain;

     

       591
       +
             })

     

       592
       +
       

     

       593
       +
         | `Bool b ->

     

       594
       +
             emit t (Event.Scalar {

     

       595
       +
               anchor = None; tag = None;

     

       596
       +
               value = if b then "true" else "false";

     

       597
       +
               plain_implicit = true; quoted_implicit = false;

     

       598
       +
               style = Scalar_style.Plain;

     

       599
       +
             })

     

       600
       +
       

     

       601
       +
         | `Float f ->

     

       602
       +
             let value =

     

       603
       +
               match Float.classify_float f with

     

       604
       +
               | FP_nan -> ".nan"

     

       605
       +
               | FP_infinite -> if f > 0.0 then ".inf" else "-.inf"

     

       606
       +
               | _ ->

     

       607
       +
                   if Float.is_integer f && Float.abs f < 1e15 then

     

       608
       +
                     Printf.sprintf "%.0f" f

     

       609
       +
                   else

     

       610
       +
                     Printf.sprintf "%g" f

     

       611
       +
             in

     

       612
       +
             emit t (Event.Scalar {

     

       613
       +
               anchor = None; tag = None;

     

       614
       +
               value;

     

       615
       +
               plain_implicit = true; quoted_implicit = false;

     

       616
       +
               style = Scalar_style.Plain;

     

       617
       +
             })

     

       618
       +
       

     

       619
       +
         | `String s ->

     

       620
       +
             let style =

     

       621
       +
               if needs_double_quotes s then Scalar_style.Double_quoted

     

       622
       +
               else if needs_quoting s then Scalar_style.Single_quoted

     

       623
       +
               else Scalar_style.Plain

     

       624
       +
             in

     

       625
       +
             emit t (Event.Scalar {

     

       626
       +
               anchor = None; tag = None;

     

       627
       +
               value = s;

     

       628
       +
               plain_implicit = style = Scalar_style.Plain;

     

       629
       +
               quoted_implicit = style <> Scalar_style.Plain;

     

       630
       +
               style;

     

       631
       +
             })

     

       632
       +
       

     

       633
       +
         | `A items ->

     

       634
       +
             let style =

     

       635
       +
               if t.config.layout_style = Layout_style.Flow then Layout_style.Flow

     

       636
       +
               else Layout_style.Block

     

       637
       +
             in

     

       638
       +
             emit t (Event.Sequence_start {

     

       639
       +
               anchor = None; tag = None;

     

       640
       +
               implicit = true;

     

       641
       +
               style;

     

       642
       +
             });

     

       643
       +
             List.iter (emit_value_node t) items;

     

       644
       +
             emit t Event.Sequence_end

     

       645
       +
       

     

       646
       +
         | `O pairs ->

     

       647
       +
             let style =

     

       648
       +
               if t.config.layout_style = Layout_style.Flow then Layout_style.Flow

     

       649
       +
               else Layout_style.Block

     

       650
       +
             in

     

       651
       +
             emit t (Event.Mapping_start {

     

       652
       +
               anchor = None; tag = None;

     

       653
       +
               implicit = true;

     

       654
       +
               style;

     

       655
       +
             });

     

       656
       +
             List.iter (fun (k, v) ->

     

       657
       +
               emit t (Event.Scalar {

     

       658
       +
                 anchor = None; tag = None;

     

       659
       +
                 value = k;

     

       660
       +
                 plain_implicit = not (needs_quoting k);

     

       661
       +
                 quoted_implicit = needs_quoting k;

     

       662
       +
                 style = if needs_quoting k then Scalar_style.Double_quoted else Scalar_style.Plain;

     

       663
       +
               });

     

       664
       +
               emit_value_node t v

     

       665
       +
             ) pairs;

     

       666
       +
             emit t Event.Mapping_end

     

       667
       +
       

     

       668
       +
       let emit_value t value =

     

       669
       +
         emit t (Event.Stream_start { encoding = t.config.encoding });

     

       670
       +
         emit t (Event.Document_start { version = None; implicit = true });

     

       671
       +
         emit_value_node t value;

     

       672
       +
         emit t (Event.Document_end { implicit = true });

     

       673
       +
         emit t Event.Stream_end

     

       674
       +
       

     

       675
       +
       let emit_document t doc =

     

       676
       +
         emit t (Event.Document_start {

     

       677
       +
           version = Document.version doc;

     

       678
       +
           implicit = Document.implicit_start doc;

     

       679
       +
         });

     

       680
       +
         (match Document.root doc with

     

       681
       +
          | Some yaml -> emit_yaml_node t yaml

     

       682
       +
          | None ->

     

       683
       +
              emit t (Event.Scalar {

     

       684
       +
                anchor = None; tag = None;

     

       685
       +
                value = "";

     

       686
       +
                plain_implicit = true; quoted_implicit = false;

     

       687
       +
                style = Scalar_style.Plain;

     

       688
       +
              }));

     

       689
       +
         emit t (Event.Document_end { implicit = Document.implicit_end doc })

     

       690
       +
       

     

       691
       +
       (** Convenience functions *)

     

       692
       +
       

     

       693
       +
       let value_to_string ?(config = default_config) value =

     

       694
       +
         let t = create ~config () in

     

       695
       +
         emit_value t value;

     

       696
       +
         contents t

     

       697
       +
       

     

       698
       +
       let yaml_to_string ?(config = default_config) yaml =

     

       699
       +
         let t = create ~config () in

     

       700
       +
         emit_yaml t yaml;

     

       701
       +
         contents t

+54

yaml/ocaml-yamle/lib/encoding.ml

···

       1
       +
       (** Character encoding detection and handling *)

     

       2
       +
       

     

       3
       +
       type t =

     

       4
       +
         | Utf8

     

       5
       +
         | Utf16be

     

       6
       +
         | Utf16le

     

       7
       +
         | Utf32be

     

       8
       +
         | Utf32le

     

       9
       +
       

     

       10
       +
       let to_string = function

     

       11
       +
         | Utf8 -> "UTF-8"

     

       12
       +
         | Utf16be -> "UTF-16BE"

     

       13
       +
         | Utf16le -> "UTF-16LE"

     

       14
       +
         | Utf32be -> "UTF-32BE"

     

       15
       +
         | Utf32le -> "UTF-32LE"

     

       16
       +
       

     

       17
       +
       let pp fmt t =

     

       18
       +
         Format.pp_print_string fmt (to_string t)

     

       19
       +
       

     

       20
       +
       (** Detect encoding from BOM or first bytes.

     

       21
       +
           Returns (encoding, bom_length) *)

     

       22
       +
       let detect s =

     

       23
       +
         let len = String.length s in

     

       24
       +
         if len = 0 then (Utf8, 0)

     

       25
       +
         else

     

       26
       +
           let b0 = Char.code s.[0] in

     

       27
       +
           let b1 = if len > 1 then Char.code s.[1] else 0 in

     

       28
       +
           let b2 = if len > 2 then Char.code s.[2] else 0 in

     

       29
       +
           let b3 = if len > 3 then Char.code s.[3] else 0 in

     

       30
       +
           (* Check for BOM first *)

     

       31
       +
           if b0 = 0xEF && b1 = 0xBB && b2 = 0xBF then

     

       32
       +
             (Utf8, 3)

     

       33
       +
           else if b0 = 0xFE && b1 = 0xFF then

     

       34
       +
             (Utf16be, 2)

     

       35
       +
           else if b0 = 0xFF && b1 = 0xFE then

     

       36
       +
             if b2 = 0x00 && b3 = 0x00 then

     

       37
       +
               (Utf32le, 4)

     

       38
       +
             else

     

       39
       +
               (Utf16le, 2)

     

       40
       +
           else if b0 = 0x00 && b1 = 0x00 && b2 = 0xFE && b3 = 0xFF then

     

       41
       +
             (Utf32be, 4)

     

       42
       +
           (* No BOM - detect from content pattern *)

     

       43
       +
           else if b0 = 0x00 && b1 = 0x00 && b2 = 0x00 && b3 <> 0x00 then

     

       44
       +
             (Utf32be, 0)

     

       45
       +
           else if b0 <> 0x00 && b1 = 0x00 && b2 = 0x00 && b3 = 0x00 then

     

       46
       +
             (Utf32le, 0)

     

       47
       +
           else if b0 = 0x00 && b1 <> 0x00 then

     

       48
       +
             (Utf16be, 0)

     

       49
       +
           else if b0 <> 0x00 && b1 = 0x00 then

     

       50
       +
             (Utf16le, 0)

     

       51
       +
           else

     

       52
       +
             (Utf8, 0)

     

       53
       +
       

     

       54
       +
       let equal a b = a = b

+179

yaml/ocaml-yamle/lib/error.ml

···

       1
       +
       (** Error handling with position information *)

     

       2
       +
       

     

       3
       +
       (** Error classification *)

     

       4
       +
       type kind =

     

       5
       +
         (* Scanner errors *)

     

       6
       +
         | Unexpected_character of char

     

       7
       +
         | Unexpected_eof

     

       8
       +
         | Invalid_escape_sequence of string

     

       9
       +
         | Invalid_unicode_escape of string

     

       10
       +
         | Invalid_hex_escape of string

     

       11
       +
         | Invalid_tag of string

     

       12
       +
         | Invalid_anchor of string

     

       13
       +
         | Invalid_alias of string

     

       14
       +
         | Unclosed_single_quote

     

       15
       +
         | Unclosed_double_quote

     

       16
       +
         | Unclosed_flow_sequence

     

       17
       +
         | Unclosed_flow_mapping

     

       18
       +
         | Invalid_indentation of int * int  (** expected, got *)

     

       19
       +
         | Tab_in_indentation

     

       20
       +
         | Invalid_block_scalar_header of string

     

       21
       +
         | Invalid_directive of string

     

       22
       +
         | Invalid_yaml_version of string

     

       23
       +
         | Invalid_tag_directive of string

     

       24
       +
         | Reserved_directive of string

     

       25
       +
       

     

       26
       +
         (* Parser errors *)

     

       27
       +
         | Unexpected_token of string

     

       28
       +
         | Expected_document_start

     

       29
       +
         | Expected_document_end

     

       30
       +
         | Expected_block_entry

     

       31
       +
         | Expected_key

     

       32
       +
         | Expected_value

     

       33
       +
         | Expected_node

     

       34
       +
         | Expected_scalar

     

       35
       +
         | Expected_sequence_end

     

       36
       +
         | Expected_mapping_end

     

       37
       +
         | Duplicate_anchor of string

     

       38
       +
         | Undefined_alias of string

     

       39
       +
         | Alias_cycle of string

     

       40
       +
         | Multiple_documents

     

       41
       +
         | Mapping_key_too_long

     

       42
       +
       

     

       43
       +
         (* Loader errors *)

     

       44
       +
         | Invalid_scalar_conversion of string * string  (** value, target type *)

     

       45
       +
         | Type_mismatch of string * string  (** expected, got *)

     

       46
       +
         | Unresolved_alias of string

     

       47
       +
         | Key_not_found of string

     

       48
       +
       

     

       49
       +
         (* Emitter errors *)

     

       50
       +
         | Invalid_encoding of string

     

       51
       +
         | Scalar_contains_invalid_chars of string

     

       52
       +
         | Anchor_not_set

     

       53
       +
         | Invalid_state of string

     

       54
       +
       

     

       55
       +
         (* Generic *)

     

       56
       +
         | Custom of string

     

       57
       +
       

     

       58
       +
       (** Full error with location *)

     

       59
       +
       type t = {

     

       60
       +
         kind : kind;

     

       61
       +
         span : Span.t option;

     

       62
       +
         context : string list;

     

       63
       +
         source : string option;

     

       64
       +
       }

     

       65
       +
       

     

       66
       +
       (** The exception raised by yamle *)

     

       67
       +
       exception Yamle_error of t

     

       68
       +
       

     

       69
       +
       let () =

     

       70
       +
         Printexc.register_printer (function

     

       71
       +
           | Yamle_error e ->

     

       72
       +
               let loc = match e.span with

     

       73
       +
                 | None -> ""

     

       74
       +
                 | Some span -> " at " ^ Span.to_string span

     

       75
       +
               in

     

       76
       +
               Some (Printf.sprintf "Yamle_error: %s%s"

     

       77
       +
                 (match e.kind with Custom s -> s | _ -> "error") loc)

     

       78
       +
           | _ -> None)

     

       79
       +
       

     

       80
       +
       let make ?span ?(context=[]) ?source kind =

     

       81
       +
         { kind; span; context; source }

     

       82
       +
       

     

       83
       +
       let raise ?span ?context ?source kind =

     

       84
       +
         Stdlib.raise (Yamle_error (make ?span ?context ?source kind))

     

       85
       +
       

     

       86
       +
       let raise_at pos kind =

     

       87
       +
         let span = Span.point pos in

     

       88
       +
         raise ~span kind

     

       89
       +
       

     

       90
       +
       let raise_span span kind =

     

       91
       +
         raise ~span kind

     

       92
       +
       

     

       93
       +
       let with_context ctx f =

     

       94
       +
         try f () with

     

       95
       +
         | Yamle_error e ->

     

       96
       +
             Stdlib.raise (Yamle_error { e with context = ctx :: e.context })

     

       97
       +
       

     

       98
       +
       let kind_to_string = function

     

       99
       +
         | Unexpected_character c -> Printf.sprintf "unexpected character %C" c

     

       100
       +
         | Unexpected_eof -> "unexpected end of input"

     

       101
       +
         | Invalid_escape_sequence s -> Printf.sprintf "invalid escape sequence: %s" s

     

       102
       +
         | Invalid_unicode_escape s -> Printf.sprintf "invalid unicode escape: %s" s

     

       103
       +
         | Invalid_hex_escape s -> Printf.sprintf "invalid hex escape: %s" s

     

       104
       +
         | Invalid_tag s -> Printf.sprintf "invalid tag: %s" s

     

       105
       +
         | Invalid_anchor s -> Printf.sprintf "invalid anchor: %s" s

     

       106
       +
         | Invalid_alias s -> Printf.sprintf "invalid alias: %s" s

     

       107
       +
         | Unclosed_single_quote -> "unclosed single quote"

     

       108
       +
         | Unclosed_double_quote -> "unclosed double quote"

     

       109
       +
         | Unclosed_flow_sequence -> "unclosed flow sequence '['"

     

       110
       +
         | Unclosed_flow_mapping -> "unclosed flow mapping '{'"

     

       111
       +
         | Invalid_indentation (expected, got) ->

     

       112
       +
             Printf.sprintf "invalid indentation: expected %d, got %d" expected got

     

       113
       +
         | Tab_in_indentation -> "tab character in indentation"

     

       114
       +
         | Invalid_block_scalar_header s ->

     

       115
       +
             Printf.sprintf "invalid block scalar header: %s" s

     

       116
       +
         | Invalid_directive s -> Printf.sprintf "invalid directive: %s" s

     

       117
       +
         | Invalid_yaml_version s -> Printf.sprintf "invalid YAML version: %s" s

     

       118
       +
         | Invalid_tag_directive s -> Printf.sprintf "invalid TAG directive: %s" s

     

       119
       +
         | Reserved_directive s -> Printf.sprintf "reserved directive: %s" s

     

       120
       +
         | Unexpected_token s -> Printf.sprintf "unexpected token: %s" s

     

       121
       +
         | Expected_document_start -> "expected document start '---'"

     

       122
       +
         | Expected_document_end -> "expected document end '...'"

     

       123
       +
         | Expected_block_entry -> "expected block entry '-'"

     

       124
       +
         | Expected_key -> "expected mapping key"

     

       125
       +
         | Expected_value -> "expected mapping value"

     

       126
       +
         | Expected_node -> "expected node"

     

       127
       +
         | Expected_scalar -> "expected scalar"

     

       128
       +
         | Expected_sequence_end -> "expected sequence end ']'"

     

       129
       +
         | Expected_mapping_end -> "expected mapping end '}'"

     

       130
       +
         | Duplicate_anchor s -> Printf.sprintf "duplicate anchor: &%s" s

     

       131
       +
         | Undefined_alias s -> Printf.sprintf "undefined alias: *%s" s

     

       132
       +
         | Alias_cycle s -> Printf.sprintf "alias cycle detected: *%s" s

     

       133
       +
         | Multiple_documents -> "multiple documents found when single expected"

     

       134
       +
         | Mapping_key_too_long -> "mapping key too long (max 1024 characters)"

     

       135
       +
         | Invalid_scalar_conversion (value, typ) ->

     

       136
       +
             Printf.sprintf "cannot convert %S to %s" value typ

     

       137
       +
         | Type_mismatch (expected, got) ->

     

       138
       +
             Printf.sprintf "type mismatch: expected %s, got %s" expected got

     

       139
       +
         | Unresolved_alias s -> Printf.sprintf "unresolved alias: *%s" s

     

       140
       +
         | Key_not_found s -> Printf.sprintf "key not found: %s" s

     

       141
       +
         | Invalid_encoding s -> Printf.sprintf "invalid encoding: %s" s

     

       142
       +
         | Scalar_contains_invalid_chars s ->

     

       143
       +
             Printf.sprintf "scalar contains invalid characters: %s" s

     

       144
       +
         | Anchor_not_set -> "anchor not set"

     

       145
       +
         | Invalid_state s -> Printf.sprintf "invalid state: %s" s

     

       146
       +
         | Custom s -> s

     

       147
       +
       

     

       148
       +
       let to_string t =

     

       149
       +
         let loc = match t.span with

     

       150
       +
           | None -> ""

     

       151
       +
           | Some span -> " at " ^ Span.to_string span

     

       152
       +
         in

     

       153
       +
         let ctx = match t.context with

     

       154
       +
           | [] -> ""

     

       155
       +
           | ctxs -> " (in " ^ String.concat " > " (List.rev ctxs) ^ ")"

     

       156
       +
         in

     

       157
       +
         kind_to_string t.kind ^ loc ^ ctx

     

       158
       +
       

     

       159
       +
       let pp fmt t =

     

       160
       +
         Format.fprintf fmt "Yamle error: %s" (to_string t)

     

       161
       +
       

     

       162
       +
       let extract_line source line_num =

     

       163
       +
         let lines = String.split_on_char '\n' source in

     

       164
       +
         if line_num >= 1 && line_num <= List.length lines then

     

       165
       +
           Some (List.nth lines (line_num - 1))

     

       166
       +
         else

     

       167
       +
           None

     

       168
       +
       

     

       169
       +
       let pp_with_source ~source fmt t =

     

       170
       +
         pp fmt t;

     

       171
       +
         match t.span with

     

       172
       +
         | None -> ()

     

       173
       +
         | Some span ->

     

       174
       +
             match extract_line source span.start.line with

     

       175
       +
             | None -> ()

     

       176
       +
             | Some line ->

     

       177
       +
                 Format.fprintf fmt "\n  %d | %s\n" span.start.line line;

     

       178
       +
                 let padding = String.make (span.start.column - 1) ' ' in

     

       179
       +
                 Format.fprintf fmt "    | %s^" padding

+77

yaml/ocaml-yamle/lib/event.ml

···

       1
       +
       (** YAML parser events *)

     

       2
       +
       

     

       3
       +
       type t =

     

       4
       +
         | Stream_start of { encoding : Encoding.t }

     

       5
       +
         | Stream_end

     

       6
       +
         | Document_start of {

     

       7
       +
             version : (int * int) option;

     

       8
       +
             implicit : bool;

     

       9
       +
           }

     

       10
       +
         | Document_end of { implicit : bool }

     

       11
       +
         | Alias of { anchor : string }

     

       12
       +
         | Scalar of {

     

       13
       +
             anchor : string option;

     

       14
       +
             tag : string option;

     

       15
       +
             value : string;

     

       16
       +
             plain_implicit : bool;

     

       17
       +
             quoted_implicit : bool;

     

       18
       +
             style : Scalar_style.t;

     

       19
       +
           }

     

       20
       +
         | Sequence_start of {

     

       21
       +
             anchor : string option;

     

       22
       +
             tag : string option;

     

       23
       +
             implicit : bool;

     

       24
       +
             style : Layout_style.t;

     

       25
       +
           }

     

       26
       +
         | Sequence_end

     

       27
       +
         | Mapping_start of {

     

       28
       +
             anchor : string option;

     

       29
       +
             tag : string option;

     

       30
       +
             implicit : bool;

     

       31
       +
             style : Layout_style.t;

     

       32
       +
           }

     

       33
       +
         | Mapping_end

     

       34
       +
       

     

       35
       +
       type spanned = {

     

       36
       +
         event : t;

     

       37
       +
         span : Span.t;

     

       38
       +
       }

     

       39
       +
       

     

       40
       +
       let pp fmt = function

     

       41
       +
         | Stream_start { encoding } ->

     

       42
       +
             Format.fprintf fmt "stream-start(%a)" Encoding.pp encoding

     

       43
       +
         | Stream_end ->

     

       44
       +
             Format.fprintf fmt "stream-end"

     

       45
       +
         | Document_start { version; implicit } ->

     

       46
       +
             Format.fprintf fmt "document-start(version=%s, implicit=%b)"

     

       47
       +
               (match version with None -> "none" | Some (maj, min) -> Printf.sprintf "%d.%d" maj min)

     

       48
       +
               implicit

     

       49
       +
         | Document_end { implicit } ->

     

       50
       +
             Format.fprintf fmt "document-end(implicit=%b)" implicit

     

       51
       +
         | Alias { anchor } ->

     

       52
       +
             Format.fprintf fmt "alias(%s)" anchor

     

       53
       +
         | Scalar { anchor; tag; value; style; _ } ->

     

       54
       +
             Format.fprintf fmt "scalar(anchor=%s, tag=%s, style=%a, value=%S)"

     

       55
       +
               (Option.value anchor ~default:"none")

     

       56
       +
               (Option.value tag ~default:"none")

     

       57
       +
               Scalar_style.pp style

     

       58
       +
               value

     

       59
       +
         | Sequence_start { anchor; tag; implicit; style } ->

     

       60
       +
             Format.fprintf fmt "sequence-start(anchor=%s, tag=%s, implicit=%b, style=%a)"

     

       61
       +
               (Option.value anchor ~default:"none")

     

       62
       +
               (Option.value tag ~default:"none")

     

       63
       +
               implicit

     

       64
       +
               Layout_style.pp style

     

       65
       +
         | Sequence_end ->

     

       66
       +
             Format.fprintf fmt "sequence-end"

     

       67
       +
         | Mapping_start { anchor; tag; implicit; style } ->

     

       68
       +
             Format.fprintf fmt "mapping-start(anchor=%s, tag=%s, implicit=%b, style=%a)"

     

       69
       +
               (Option.value anchor ~default:"none")

     

       70
       +
               (Option.value tag ~default:"none")

     

       71
       +
               implicit

     

       72
       +
               Layout_style.pp style

     

       73
       +
         | Mapping_end ->

     

       74
       +
             Format.fprintf fmt "mapping-end"

     

       75
       +
       

     

       76
       +
       let pp_spanned fmt { event; span } =

     

       77
       +
         Format.fprintf fmt "%a at %a" pp event Span.pp span

+146

yaml/ocaml-yamle/lib/input.ml

···

       1
       +
       (** Character input source with lookahead *)

     

       2
       +
       

     

       3
       +
       type t = {

     

       4
       +
         source : string;

     

       5
       +
         mutable pos : int;           (** Current byte position *)

     

       6
       +
         mutable position : Position.t;  (** Line/column tracking *)

     

       7
       +
         length : int;

     

       8
       +
       }

     

       9
       +
       

     

       10
       +
       let of_string source =

     

       11
       +
         let encoding, bom_len = Encoding.detect source in

     

       12
       +
         (* For now, we only support UTF-8. Skip BOM if present. *)

     

       13
       +
         ignore encoding;

     

       14
       +
         {

     

       15
       +
           source;

     

       16
       +
           pos = bom_len;

     

       17
       +
           position = Position.initial;

     

       18
       +
           length = String.length source;

     

       19
       +
         }

     

       20
       +
       

     

       21
       +
       let position t = t.position

     

       22
       +
       

     

       23
       +
       let is_eof t = t.pos >= t.length

     

       24
       +
       

     

       25
       +
       let peek t =

     

       26
       +
         if t.pos >= t.length then None

     

       27
       +
         else Some t.source.[t.pos]

     

       28
       +
       

     

       29
       +
       let peek_exn t =

     

       30
       +
         if t.pos >= t.length then

     

       31
       +
           Error.raise_at t.position Unexpected_eof

     

       32
       +
         else

     

       33
       +
           t.source.[t.pos]

     

       34
       +
       

     

       35
       +
       let peek_nth t n =

     

       36
       +
         let idx = t.pos + n in

     

       37
       +
         if idx >= t.length then None

     

       38
       +
         else Some t.source.[idx]

     

       39
       +
       

     

       40
       +
       let peek_string t n =

     

       41
       +
         if t.pos + n > t.length then

     

       42
       +
           String.sub t.source t.pos (t.length - t.pos)

     

       43
       +
         else

     

       44
       +
           String.sub t.source t.pos n

     

       45
       +
       

     

       46
       +
       let next t =

     

       47
       +
         if t.pos >= t.length then None

     

       48
       +
         else begin

     

       49
       +
           let c = t.source.[t.pos] in

     

       50
       +
           t.pos <- t.pos + 1;

     

       51
       +
           t.position <- Position.advance_char c t.position;

     

       52
       +
           Some c

     

       53
       +
         end

     

       54
       +
       

     

       55
       +
       let next_exn t =

     

       56
       +
         match next t with

     

       57
       +
         | Some c -> c

     

       58
       +
         | None -> Error.raise_at t.position Unexpected_eof

     

       59
       +
       

     

       60
       +
       let skip t n =

     

       61
       +
         for _ = 1 to n do

     

       62
       +
           ignore (next t)

     

       63
       +
         done

     

       64
       +
       

     

       65
       +
       let skip_while t pred =

     

       66
       +
         while not (is_eof t) && pred (Option.get (peek t)) do

     

       67
       +
           ignore (next t)

     

       68
       +
         done

     

       69
       +
       

     

       70
       +
       (** Character classification *)

     

       71
       +
       

     

       72
       +
       let is_break c = c = '\n' || c = '\r'

     

       73
       +
       

     

       74
       +
       let is_blank c = c = ' ' || c = '\t'

     

       75
       +
       

     

       76
       +
       let is_whitespace c = is_break c || is_blank c

     

       77
       +
       

     

       78
       +
       let is_digit c = c >= '0' && c <= '9'

     

       79
       +
       

     

       80
       +
       let is_hex c =

     

       81
       +
         (c >= '0' && c <= '9') ||

     

       82
       +
         (c >= 'a' && c <= 'f') ||

     

       83
       +
         (c >= 'A' && c <= 'F')

     

       84
       +
       

     

       85
       +
       let is_alpha c =

     

       86
       +
         (c >= 'a' && c <= 'z') ||

     

       87
       +
         (c >= 'A' && c <= 'Z')

     

       88
       +
       

     

       89
       +
       let is_alnum c = is_alpha c || is_digit c

     

       90
       +
       

     

       91
       +
       (** YAML indicator characters *)

     

       92
       +
       let is_indicator c =

     

       93
       +
         match c with

     

       94
       +
         | '-' | '?' | ':' | ',' | '[' | ']' | '{' | '}'

     

       95
       +
         | '#' | '&' | '*' | '!' | '|' | '>' | '\'' | '"'

     

       96
       +
         | '%' | '@' | '`' -> true

     

       97
       +
         | _ -> false

     

       98
       +
       

     

       99
       +
       (** Characters that cannot start a plain scalar *)

     

       100
       +
       let is_flow_indicator c =

     

       101
       +
         match c with

     

       102
       +
         | ',' | '[' | ']' | '{' | '}' -> true

     

       103
       +
         | _ -> false

     

       104
       +
       

     

       105
       +
       (** Check if next char satisfies predicate *)

     

       106
       +
       let next_is pred t =

     

       107
       +
         match peek t with

     

       108
       +
         | None -> false

     

       109
       +
         | Some c -> pred c

     

       110
       +
       

     

       111
       +
       let next_is_break t = next_is is_break t

     

       112
       +
       let next_is_blank t = next_is is_blank t

     

       113
       +
       let next_is_whitespace t = next_is is_whitespace t

     

       114
       +
       let next_is_digit t = next_is is_digit t

     

       115
       +
       let next_is_hex t = next_is is_hex t

     

       116
       +
       let next_is_alpha t = next_is is_alpha t

     

       117
       +
       let next_is_indicator t = next_is is_indicator t

     

       118
       +
       

     

       119
       +
       (** Check if at document boundary (--- or ...) *)

     

       120
       +
       let at_document_boundary t =

     

       121
       +
         if t.position.column <> 1 then false

     

       122
       +
         else

     

       123
       +
           let s = peek_string t 4 in

     

       124
       +
           let prefix = String.sub s 0 (min 3 (String.length s)) in

     

       125
       +
           (prefix = "---" || prefix = "...") &&

     

       126
       +
           (String.length s < 4 || is_whitespace s.[3] || String.length s = 3)

     

       127
       +
       

     

       128
       +
       (** Consume line break, handling \r\n as single break *)

     

       129
       +
       let consume_break t =

     

       130
       +
         match peek t with

     

       131
       +
         | Some '\r' ->

     

       132
       +
             ignore (next t);

     

       133
       +
             (match peek t with

     

       134
       +
              | Some '\n' -> ignore (next t)

     

       135
       +
              | _ -> ())

     

       136
       +
         | Some '\n' ->

     

       137
       +
             ignore (next t)

     

       138
       +
         | _ -> ()

     

       139
       +
       

     

       140
       +
       (** Get remaining content from current position *)

     

       141
       +
       let remaining t =

     

       142
       +
         if t.pos >= t.length then ""

     

       143
       +
         else String.sub t.source t.pos (t.length - t.pos)

     

       144
       +
       

     

       145
       +
       (** Mark current position for span creation *)

     

       146
       +
       let mark t = t.position

+24

yaml/ocaml-yamle/lib/layout_style.ml

···

       1
       +
       (** Collection layout styles *)

     

       2
       +
       

     

       3
       +
       type t =

     

       4
       +
         | Any   (** Let emitter choose *)

     

       5
       +
         | Block (** Indentation-based *)

     

       6
       +
         | Flow  (** Inline with brackets *)

     

       7
       +
       

     

       8
       +
       let to_string = function

     

       9
       +
         | Any -> "any"

     

       10
       +
         | Block -> "block"

     

       11
       +
         | Flow -> "flow"

     

       12
       +
       

     

       13
       +
       let pp fmt t =

     

       14
       +
         Format.pp_print_string fmt (to_string t)

     

       15
       +
       

     

       16
       +
       let equal a b = a = b

     

       17
       +
       

     

       18
       +
       let compare a b =

     

       19
       +
         let to_int = function

     

       20
       +
           | Any -> 0

     

       21
       +
           | Block -> 1

     

       22
       +
           | Flow -> 2

     

       23
       +
         in

     

       24
       +
         Int.compare (to_int a) (to_int b)

+243

yaml/ocaml-yamle/lib/loader.ml

···

       1
       +
       (** Loader - converts parser events to YAML data structures *)

     

       2
       +
       

     

       3
       +
       (** Stack frame for building nested structures *)

     

       4
       +
       type frame =

     

       5
       +
         | Sequence_frame of {

     

       6
       +
             anchor : string option;

     

       7
       +
             tag : string option;

     

       8
       +
             implicit : bool;

     

       9
       +
             style : Layout_style.t;

     

       10
       +
             items : Yaml.t list;

     

       11
       +
           }

     

       12
       +
         | Mapping_frame of {

     

       13
       +
             anchor : string option;

     

       14
       +
             tag : string option;

     

       15
       +
             implicit : bool;

     

       16
       +
             style : Layout_style.t;

     

       17
       +
             pairs : (Yaml.t * Yaml.t) list;

     

       18
       +
             pending_key : Yaml.t option;

     

       19
       +
           }

     

       20
       +
       

     

       21
       +
       type state = {

     

       22
       +
         mutable stack : frame list;

     

       23
       +
         mutable current : Yaml.t option;

     

       24
       +
         mutable documents : Document.t list;

     

       25
       +
         mutable doc_version : (int * int) option;

     

       26
       +
         mutable doc_implicit_start : bool;

     

       27
       +
       }

     

       28
       +
       

     

       29
       +
       let create_state () = {

     

       30
       +
         stack = [];

     

       31
       +
         current = None;

     

       32
       +
         documents = [];

     

       33
       +
         doc_version = None;

     

       34
       +
         doc_implicit_start = true;

     

       35
       +
       }

     

       36
       +
       

     

       37
       +
       (** Process a single event *)

     

       38
       +
       let rec process_event state (ev : Event.spanned) =

     

       39
       +
         match ev.event with

     

       40
       +
         | Event.Stream_start _ -> ()

     

       41
       +
       

     

       42
       +
         | Event.Stream_end -> ()

     

       43
       +
       

     

       44
       +
         | Event.Document_start { version; implicit } ->

     

       45
       +
             state.doc_version <- version;

     

       46
       +
             state.doc_implicit_start <- implicit

     

       47
       +
       

     

       48
       +
         | Event.Document_end { implicit } ->

     

       49
       +
             let doc = Document.make

     

       50
       +
               ?version:state.doc_version

     

       51
       +
               ~implicit_start:state.doc_implicit_start

     

       52
       +
               ~implicit_end:implicit

     

       53
       +
               state.current

     

       54
       +
             in

     

       55
       +
             state.documents <- doc :: state.documents;

     

       56
       +
             state.current <- None;

     

       57
       +
             state.doc_version <- None;

     

       58
       +
             state.doc_implicit_start <- true

     

       59
       +
       

     

       60
       +
         | Event.Alias { anchor } ->

     

       61
       +
             let node : Yaml.t = `Alias anchor in

     

       62
       +
             add_node state node

     

       63
       +
       

     

       64
       +
         | Event.Scalar { anchor; tag; value; plain_implicit; quoted_implicit; style } ->

     

       65
       +
             let scalar = Scalar.make

     

       66
       +
               ?anchor ?tag

     

       67
       +
               ~plain_implicit ~quoted_implicit

     

       68
       +
               ~style value

     

       69
       +
             in

     

       70
       +
             let node : Yaml.t = `Scalar scalar in

     

       71
       +
             add_node state node

     

       72
       +
       

     

       73
       +
         | Event.Sequence_start { anchor; tag; implicit; style } ->

     

       74
       +
             let frame = Sequence_frame {

     

       75
       +
               anchor; tag; implicit; style;

     

       76
       +
               items = [];

     

       77
       +
             } in

     

       78
       +
             state.stack <- frame :: state.stack

     

       79
       +
       

     

       80
       +
         | Event.Sequence_end ->

     

       81
       +
             (match state.stack with

     

       82
       +
              | Sequence_frame { anchor; tag; implicit; style; items } :: rest ->

     

       83
       +
                  let seq = Sequence.make ?anchor ?tag ~implicit ~style (List.rev items) in

     

       84
       +
                  let node : Yaml.t = `A seq in

     

       85
       +
                  state.stack <- rest;

     

       86
       +
                  add_node state node

     

       87
       +
              | _ -> Error.raise (Invalid_state "unexpected sequence end"))

     

       88
       +
       

     

       89
       +
         | Event.Mapping_start { anchor; tag; implicit; style } ->

     

       90
       +
             let frame = Mapping_frame {

     

       91
       +
               anchor; tag; implicit; style;

     

       92
       +
               pairs = [];

     

       93
       +
               pending_key = None;

     

       94
       +
             } in

     

       95
       +
             state.stack <- frame :: state.stack

     

       96
       +
       

     

       97
       +
         | Event.Mapping_end ->

     

       98
       +
             (match state.stack with

     

       99
       +
              | Mapping_frame { anchor; tag; implicit; style; pairs; pending_key = None } :: rest ->

     

       100
       +
                  let map = Mapping.make ?anchor ?tag ~implicit ~style (List.rev pairs) in

     

       101
       +
                  let node : Yaml.t = `O map in

     

       102
       +
                  state.stack <- rest;

     

       103
       +
                  add_node state node

     

       104
       +
              | Mapping_frame { pending_key = Some _; _ } :: _ ->

     

       105
       +
                  Error.raise (Invalid_state "mapping ended with pending key")

     

       106
       +
              | _ -> Error.raise (Invalid_state "unexpected mapping end"))

     

       107
       +
       

     

       108
       +
       (** Add a node to current context *)

     

       109
       +
       and add_node state node =

     

       110
       +
         match state.stack with

     

       111
       +
         | [] ->

     

       112
       +
             state.current <- Some node

     

       113
       +
       

     

       114
       +
         | Sequence_frame f :: rest ->

     

       115
       +
             state.stack <- Sequence_frame { f with items = node :: f.items } :: rest

     

       116
       +
       

     

       117
       +
         | Mapping_frame f :: rest ->

     

       118
       +
             (match f.pending_key with

     

       119
       +
              | None ->

     

       120
       +
                  (* This is a key *)

     

       121
       +
                  state.stack <- Mapping_frame { f with pending_key = Some node } :: rest

     

       122
       +
              | Some key ->

     

       123
       +
                  (* This is a value *)

     

       124
       +
                  state.stack <- Mapping_frame {

     

       125
       +
                    f with

     

       126
       +
                    pairs = (key, node) :: f.pairs;

     

       127
       +
                    pending_key = None;

     

       128
       +
                  } :: rest)

     

       129
       +
       

     

       130
       +
       (** Load single document as Value *)

     

       131
       +
       let value_of_string s =

     

       132
       +
         let parser = Parser.of_string s in

     

       133
       +
         let state = create_state () in

     

       134
       +
         Parser.iter (process_event state) parser;

     

       135
       +
         match state.documents with

     

       136
       +
         | [] -> `Null

     

       137
       +
         | [doc] ->

     

       138
       +
             (match Document.root doc with

     

       139
       +
              | None -> `Null

     

       140
       +
              | Some yaml -> Yaml.to_value yaml)

     

       141
       +
         | _ -> Error.raise Multiple_documents

     

       142
       +
       

     

       143
       +
       (** Load single document as Yaml *)

     

       144
       +
       let yaml_of_string s =

     

       145
       +
         let parser = Parser.of_string s in

     

       146
       +
         let state = create_state () in

     

       147
       +
         Parser.iter (process_event state) parser;

     

       148
       +
         match state.documents with

     

       149
       +
         | [] -> `Scalar (Scalar.make "")

     

       150
       +
         | [doc] ->

     

       151
       +
             (match Document.root doc with

     

       152
       +
              | None -> `Scalar (Scalar.make "")

     

       153
       +
              | Some yaml -> yaml)

     

       154
       +
         | _ -> Error.raise Multiple_documents

     

       155
       +
       

     

       156
       +
       (** Load all documents *)

     

       157
       +
       let documents_of_string s =

     

       158
       +
         let parser = Parser.of_string s in

     

       159
       +
         let state = create_state () in

     

       160
       +
         Parser.iter (process_event state) parser;

     

       161
       +
         List.rev state.documents

     

       162
       +
       

     

       163
       +
       (** Load single Value from parser *)

     

       164
       +
       let load_value parser =

     

       165
       +
         let state = create_state () in

     

       166
       +
         let rec loop () =

     

       167
       +
           match Parser.next parser with

     

       168
       +
           | None -> None

     

       169
       +
           | Some ev ->

     

       170
       +
               process_event state ev;

     

       171
       +
               match ev.event with

     

       172
       +
               | Event.Document_end _ ->

     

       173
       +
                   (match state.documents with

     

       174
       +
                    | doc :: _ ->

     

       175
       +
                        state.documents <- [];

     

       176
       +
                        Some (match Document.root doc with

     

       177
       +
                          | None -> `Null

     

       178
       +
                          | Some yaml -> Yaml.to_value yaml)

     

       179
       +
                    | [] -> None)

     

       180
       +
               | Event.Stream_end -> None

     

       181
       +
               | _ -> loop ()

     

       182
       +
         in

     

       183
       +
         loop ()

     

       184
       +
       

     

       185
       +
       (** Load single Yaml from parser *)

     

       186
       +
       let load_yaml parser =

     

       187
       +
         let state = create_state () in

     

       188
       +
         let rec loop () =

     

       189
       +
           match Parser.next parser with

     

       190
       +
           | None -> None

     

       191
       +
           | Some ev ->

     

       192
       +
               process_event state ev;

     

       193
       +
               match ev.event with

     

       194
       +
               | Event.Document_end _ ->

     

       195
       +
                   (match state.documents with

     

       196
       +
                    | doc :: _ ->

     

       197
       +
                        state.documents <- [];

     

       198
       +
                        Some (match Document.root doc with

     

       199
       +
                          | None -> `Scalar (Scalar.make "")

     

       200
       +
                          | Some yaml -> yaml)

     

       201
       +
                    | [] -> None)

     

       202
       +
               | Event.Stream_end -> None

     

       203
       +
               | _ -> loop ()

     

       204
       +
         in

     

       205
       +
         loop ()

     

       206
       +
       

     

       207
       +
       (** Load single Document from parser *)

     

       208
       +
       let load_document parser =

     

       209
       +
         let state = create_state () in

     

       210
       +
         let rec loop () =

     

       211
       +
           match Parser.next parser with

     

       212
       +
           | None -> None

     

       213
       +
           | Some ev ->

     

       214
       +
               process_event state ev;

     

       215
       +
               match ev.event with

     

       216
       +
               | Event.Document_end _ ->

     

       217
       +
                   (match state.documents with

     

       218
       +
                    | doc :: _ ->

     

       219
       +
                        state.documents <- [];

     

       220
       +
                        Some doc

     

       221
       +
                    | [] -> None)

     

       222
       +
               | Event.Stream_end -> None

     

       223
       +
               | _ -> loop ()

     

       224
       +
         in

     

       225
       +
         loop ()

     

       226
       +
       

     

       227
       +
       (** Iterate over documents *)

     

       228
       +
       let iter_documents f parser =

     

       229
       +
         let rec loop () =

     

       230
       +
           match load_document parser with

     

       231
       +
           | None -> ()

     

       232
       +
           | Some doc -> f doc; loop ()

     

       233
       +
         in

     

       234
       +
         loop ()

     

       235
       +
       

     

       236
       +
       (** Fold over documents *)

     

       237
       +
       let fold_documents f init parser =

     

       238
       +
         let rec loop acc =

     

       239
       +
           match load_document parser with

     

       240
       +
           | None -> acc

     

       241
       +
           | Some doc -> loop (f acc doc)

     

       242
       +
         in

     

       243
       +
         loop init

+92

yaml/ocaml-yamle/lib/mapping.ml

···

       1
       +
       (** YAML mapping (object) values with metadata *)

     

       2
       +
       

     

       3
       +
       type ('k, 'v) t = {

     

       4
       +
         anchor : string option;

     

       5
       +
         tag : string option;

     

       6
       +
         implicit : bool;

     

       7
       +
         style : Layout_style.t;

     

       8
       +
         members : ('k * 'v) list;

     

       9
       +
       }

     

       10
       +
       

     

       11
       +
       let make

     

       12
       +
           ?(anchor : string option)

     

       13
       +
           ?(tag : string option)

     

       14
       +
           ?(implicit = true)

     

       15
       +
           ?(style = Layout_style.Any)

     

       16
       +
           members =

     

       17
       +
         { anchor; tag; implicit; style; members }

     

       18
       +
       

     

       19
       +
       let members t = t.members

     

       20
       +
       let anchor t = t.anchor

     

       21
       +
       let tag t = t.tag

     

       22
       +
       let implicit t = t.implicit

     

       23
       +
       let style t = t.style

     

       24
       +
       

     

       25
       +
       let with_anchor anchor t = { t with anchor = Some anchor }

     

       26
       +
       let with_tag tag t = { t with tag = Some tag }

     

       27
       +
       let with_style style t = { t with style }

     

       28
       +
       

     

       29
       +
       let map_keys f t = { t with members = List.map (fun (k, v) -> (f k, v)) t.members }

     

       30
       +
       let map_values f t = { t with members = List.map (fun (k, v) -> (k, f v)) t.members }

     

       31
       +
       let map f t = { t with members = List.map (fun (k, v) -> f k v) t.members }

     

       32
       +
       

     

       33
       +
       let length t = List.length t.members

     

       34
       +
       

     

       35
       +
       let is_empty t = t.members = []

     

       36
       +
       

     

       37
       +
       let find pred t =

     

       38
       +
         match List.find_opt (fun (k, _) -> pred k) t.members with

     

       39
       +
         | Some (_, v) -> Some v

     

       40
       +
         | None -> None

     

       41
       +
       

     

       42
       +
       let find_key pred t =

     

       43
       +
         List.find_opt (fun (k, _) -> pred k) t.members

     

       44
       +
       

     

       45
       +
       let mem pred t =

     

       46
       +
         List.exists (fun (k, _) -> pred k) t.members

     

       47
       +
       

     

       48
       +
       let keys t = List.map fst t.members

     

       49
       +
       

     

       50
       +
       let values t = List.map snd t.members

     

       51
       +
       

     

       52
       +
       let iter f t = List.iter (fun (k, v) -> f k v) t.members

     

       53
       +
       

     

       54
       +
       let fold f init t = List.fold_left (fun acc (k, v) -> f acc k v) init t.members

     

       55
       +
       

     

       56
       +
       let pp pp_key pp_val fmt t =

     

       57
       +
         Format.fprintf fmt "@[<hv 2>mapping(@,";

     

       58
       +
         (match t.anchor with

     

       59
       +
          | Some a -> Format.fprintf fmt "anchor=%s,@ " a

     

       60
       +
          | None -> ());

     

       61
       +
         (match t.tag with

     

       62
       +
          | Some tag -> Format.fprintf fmt "tag=%s,@ " tag

     

       63
       +
          | None -> ());

     

       64
       +
         Format.fprintf fmt "style=%a,@ " Layout_style.pp t.style;

     

       65
       +
         Format.fprintf fmt "members={@,";

     

       66
       +
         List.iteri (fun i (k, v) ->

     

       67
       +
           if i > 0 then Format.fprintf fmt ",@ ";

     

       68
       +
           Format.fprintf fmt "@[<hv 2>%a:@ %a@]" pp_key k pp_val v

     

       69
       +
         ) t.members;

     

       70
       +
         Format.fprintf fmt "@]@,})"

     

       71
       +
       

     

       72
       +
       let equal eq_k eq_v a b =

     

       73
       +
         Option.equal String.equal a.anchor b.anchor &&

     

       74
       +
         Option.equal String.equal a.tag b.tag &&

     

       75
       +
         a.implicit = b.implicit &&

     

       76
       +
         Layout_style.equal a.style b.style &&

     

       77
       +
         List.equal (fun (k1, v1) (k2, v2) -> eq_k k1 k2 && eq_v v1 v2) a.members b.members

     

       78
       +
       

     

       79
       +
       let compare cmp_k cmp_v a b =

     

       80
       +
         let c = Option.compare String.compare a.anchor b.anchor in

     

       81
       +
         if c <> 0 then c else

     

       82
       +
         let c = Option.compare String.compare a.tag b.tag in

     

       83
       +
         if c <> 0 then c else

     

       84
       +
         let c = Bool.compare a.implicit b.implicit in

     

       85
       +
         if c <> 0 then c else

     

       86
       +
         let c = Layout_style.compare a.style b.style in

     

       87
       +
         if c <> 0 then c else

     

       88
       +
         let cmp_pair (k1, v1) (k2, v2) =

     

       89
       +
           let c = cmp_k k1 k2 in

     

       90
       +
           if c <> 0 then c else cmp_v v1 v2

     

       91
       +
         in

     

       92
       +
         List.compare cmp_pair a.members b.members

+711

yaml/ocaml-yamle/lib/parser.ml

···

       1
       +
       (** YAML parser - converts tokens to semantic events via state machine *)

     

       2
       +
       

     

       3
       +
       (** Parser states *)

     

       4
       +
       type state =

     

       5
       +
         | Stream_start

     

       6
       +
         | Implicit_document_start

     

       7
       +
         | Document_start

     

       8
       +
         | Document_content

     

       9
       +
         | Document_end

     

       10
       +
         | Block_node

     

       11
       +
         | Block_node_or_indentless_sequence

     

       12
       +
         | Flow_node

     

       13
       +
         | Block_sequence_first_entry

     

       14
       +
         | Block_sequence_entry

     

       15
       +
         | Indentless_sequence_entry

     

       16
       +
         | Block_mapping_first_key

     

       17
       +
         | Block_mapping_key

     

       18
       +
         | Block_mapping_value

     

       19
       +
         | Flow_sequence_first_entry

     

       20
       +
         | Flow_sequence_entry

     

       21
       +
         | Flow_sequence_entry_mapping_key

     

       22
       +
         | Flow_sequence_entry_mapping_value

     

       23
       +
         | Flow_sequence_entry_mapping_end

     

       24
       +
         | Flow_mapping_first_key

     

       25
       +
         | Flow_mapping_key

     

       26
       +
         | Flow_mapping_value

     

       27
       +
         | Flow_mapping_empty_value

     

       28
       +
         | End

     

       29
       +
       

     

       30
       +
       type t = {

     

       31
       +
         scanner : Scanner.t;

     

       32
       +
         mutable state : state;

     

       33
       +
         mutable states : state list;  (** State stack *)

     

       34
       +
         mutable marks : Span.t list;  (** Mark stack for span tracking *)

     

       35
       +
         mutable version : (int * int) option;

     

       36
       +
         mutable tag_directives : (string * string) list;

     

       37
       +
         mutable current_token : Token.spanned option;

     

       38
       +
         mutable finished : bool;

     

       39
       +
       }

     

       40
       +
       

     

       41
       +
       let create scanner = {

     

       42
       +
         scanner;

     

       43
       +
         state = Stream_start;

     

       44
       +
         states = [];

     

       45
       +
         marks = [];

     

       46
       +
         version = None;

     

       47
       +
         tag_directives = [

     

       48
       +
           ("!", "!");

     

       49
       +
           ("!!", "tag:yaml.org,2002:");

     

       50
       +
         ];

     

       51
       +
         current_token = None;

     

       52
       +
         finished = false;

     

       53
       +
       }

     

       54
       +
       

     

       55
       +
       let of_string s = create (Scanner.of_string s)

     

       56
       +
       

     

       57
       +
       (** Get current token, fetching if needed *)

     

       58
       +
       let current_token t =

     

       59
       +
         match t.current_token with

     

       60
       +
         | Some tok -> tok

     

       61
       +
         | None ->

     

       62
       +
             let tok = Scanner.next t.scanner in

     

       63
       +
             t.current_token <- tok;

     

       64
       +
             match tok with

     

       65
       +
             | Some tok -> tok

     

       66
       +
             | None -> Error.raise Unexpected_eof

     

       67
       +
       

     

       68
       +
       (** Peek at current token *)

     

       69
       +
       let peek_token t =

     

       70
       +
         match t.current_token with

     

       71
       +
         | Some _ -> t.current_token

     

       72
       +
         | None ->

     

       73
       +
             t.current_token <- Scanner.next t.scanner;

     

       74
       +
             t.current_token

     

       75
       +
       

     

       76
       +
       (** Skip current token *)

     

       77
       +
       let skip_token t =

     

       78
       +
         t.current_token <- None

     

       79
       +
       

     

       80
       +
       (** Check if current token matches *)

     

       81
       +
       let check t pred =

     

       82
       +
         match peek_token t with

     

       83
       +
         | Some tok -> pred tok.token

     

       84
       +
         | None -> false

     

       85
       +
       

     

       86
       +
       (** Check for specific token *)

     

       87
       +
       let check_token t token_match =

     

       88
       +
         check t token_match

     

       89
       +
       

     

       90
       +
       (** Push state onto stack *)

     

       91
       +
       let push_state t s =

     

       92
       +
         t.states <- s :: t.states

     

       93
       +
       

     

       94
       +
       (** Pop state from stack *)

     

       95
       +
       let pop_state t =

     

       96
       +
         match t.states with

     

       97
       +
         | s :: rest ->

     

       98
       +
             t.states <- rest;

     

       99
       +
             s

     

       100
       +
         | [] -> End

     

       101
       +
       

     

       102
       +
       (** Resolve a tag *)

     

       103
       +
       let resolve_tag t ~handle ~suffix =

     

       104
       +
         match List.assoc_opt handle t.tag_directives with

     

       105
       +
         | Some prefix -> prefix ^ suffix

     

       106
       +
         | None when handle = "!" -> "!" ^ suffix

     

       107
       +
         | None -> Error.raise (Invalid_tag (handle ^ suffix))

     

       108
       +
       

     

       109
       +
       (** Process directives at document start *)

     

       110
       +
       let process_directives t =

     

       111
       +
         t.version <- None;

     

       112
       +
         t.tag_directives <- [("!", "!"); ("!!", "tag:yaml.org,2002:")];

     

       113
       +
       

     

       114
       +
         while check t (function

     

       115
       +
           | Token.Version_directive _ | Token.Tag_directive _ -> true

     

       116
       +
           | _ -> false)

     

       117
       +
         do

     

       118
       +
           let tok = current_token t in

     

       119
       +
           skip_token t;

     

       120
       +
           match tok.token with

     

       121
       +
           | Token.Version_directive { major; minor } ->

     

       122
       +
               if t.version <> None then

     

       123
       +
                 Error.raise_span tok.span (Invalid_yaml_version "duplicate YAML directive");

     

       124
       +
               t.version <- Some (major, minor)

     

       125
       +
           | Token.Tag_directive { handle; prefix } ->

     

       126
       +
               if List.mem_assoc handle t.tag_directives &&

     

       127
       +
                  handle <> "!" && handle <> "!!" then

     

       128
       +
                 Error.raise_span tok.span (Invalid_tag_directive ("duplicate tag handle: " ^ handle));

     

       129
       +
               t.tag_directives <- (handle, prefix) :: t.tag_directives

     

       130
       +
           | _ -> ()

     

       131
       +
         done

     

       132
       +
       

     

       133
       +
       (** Parse anchor and/or tag properties *)

     

       134
       +
       let parse_properties t =

     

       135
       +
         let anchor = ref None in

     

       136
       +
         let tag = ref None in

     

       137
       +
       

     

       138
       +
         while check t (function

     

       139
       +
           | Token.Anchor _ | Token.Tag _ -> true

     

       140
       +
           | _ -> false)

     

       141
       +
         do

     

       142
       +
           let tok = current_token t in

     

       143
       +
           skip_token t;

     

       144
       +
           match tok.token with

     

       145
       +
           | Token.Anchor name ->

     

       146
       +
               if !anchor <> None then

     

       147
       +
                 Error.raise_span tok.span (Duplicate_anchor name);

     

       148
       +
               anchor := Some name

     

       149
       +
           | Token.Tag { handle; suffix } ->

     

       150
       +
               if !tag <> None then

     

       151
       +
                 Error.raise_span tok.span (Invalid_tag "duplicate tag");

     

       152
       +
               let resolved =

     

       153
       +
                 if handle = "" && suffix = "" then None

     

       154
       +
                 else if handle = "!" && suffix = "" then Some "!"

     

       155
       +
                 else Some (resolve_tag t ~handle ~suffix)

     

       156
       +
               in

     

       157
       +
               tag := resolved

     

       158
       +
           | _ -> ()

     

       159
       +
         done;

     

       160
       +
         (!anchor, !tag)

     

       161
       +
       

     

       162
       +
       (** Empty scalar event *)

     

       163
       +
       let empty_scalar_event ~anchor ~tag span =

     

       164
       +
         Event.Scalar {

     

       165
       +
           anchor;

     

       166
       +
           tag;

     

       167
       +
           value = "";

     

       168
       +
           plain_implicit = tag = None;

     

       169
       +
           quoted_implicit = false;

     

       170
       +
           style = Scalar_style.Plain;

     

       171
       +
         }, span

     

       172
       +
       

     

       173
       +
       (** Parse stream start *)

     

       174
       +
       let parse_stream_start t =

     

       175
       +
         let tok = current_token t in

     

       176
       +
         skip_token t;

     

       177
       +
         match tok.token with

     

       178
       +
         | Token.Stream_start encoding ->

     

       179
       +
             t.state <- Implicit_document_start;

     

       180
       +
             Event.Stream_start { encoding }, tok.span

     

       181
       +
         | _ ->

     

       182
       +
             Error.raise_span tok.span (Unexpected_token "expected stream start")

     

       183
       +
       

     

       184
       +
       (** Parse document start (implicit or explicit) *)

     

       185
       +
       let parse_document_start t ~implicit =

     

       186
       +
         process_directives t;

     

       187
       +
       

     

       188
       +
         if not implicit then begin

     

       189
       +
           let tok = current_token t in

     

       190
       +
           match tok.token with

     

       191
       +
           | Token.Document_start ->

     

       192
       +
               skip_token t

     

       193
       +
           | _ ->

     

       194
       +
               Error.raise_span tok.span Expected_document_start

     

       195
       +
         end;

     

       196
       +
       

     

       197
       +
         let span = match peek_token t with

     

       198
       +
           | Some tok -> tok.span

     

       199
       +
           | None -> Span.point Position.initial

     

       200
       +
         in

     

       201
       +
       

     

       202
       +
         push_state t Document_end;

     

       203
       +
         t.state <- Document_content;

     

       204
       +
         Event.Document_start { version = t.version; implicit }, span

     

       205
       +
       

     

       206
       +
       (** Parse document end *)

     

       207
       +
       let parse_document_end t =

     

       208
       +
         let implicit = not (check t (function Token.Document_end -> true | _ -> false)) in

     

       209
       +
         let span = match peek_token t with

     

       210
       +
           | Some tok -> tok.span

     

       211
       +
           | None -> Span.point Position.initial

     

       212
       +
         in

     

       213
       +
       

     

       214
       +
         if not implicit then skip_token t;

     

       215
       +
       

     

       216
       +
         t.state <- Implicit_document_start;

     

       217
       +
         Event.Document_end { implicit }, span

     

       218
       +
       

     

       219
       +
       (** Parse node in various contexts *)

     

       220
       +
       let parse_node t ~block ~indentless =

     

       221
       +
         let tok = current_token t in

     

       222
       +
         match tok.token with

     

       223
       +
         | Token.Alias name ->

     

       224
       +
             skip_token t;

     

       225
       +
             t.state <- pop_state t;

     

       226
       +
             Event.Alias { anchor = name }, tok.span

     

       227
       +
       

     

       228
       +
         | Token.Anchor _ | Token.Tag _ ->

     

       229
       +
             let anchor, tag = parse_properties t in

     

       230
       +
             let tok = current_token t in

     

       231
       +
             (match tok.token with

     

       232
       +
              | Token.Block_entry when indentless ->

     

       233
       +
                  t.state <- Indentless_sequence_entry;

     

       234
       +
                  Event.Sequence_start {

     

       235
       +
                    anchor; tag;

     

       236
       +
                    implicit = tag = None;

     

       237
       +
                    style = Layout_style.Block;

     

       238
       +
                  }, tok.span

     

       239
       +
       

     

       240
       +
              | Token.Block_sequence_start when block ->

     

       241
       +
                  t.state <- Block_sequence_first_entry;

     

       242
       +
                  skip_token t;

     

       243
       +
                  Event.Sequence_start {

     

       244
       +
                    anchor; tag;

     

       245
       +
                    implicit = tag = None;

     

       246
       +
                    style = Layout_style.Block;

     

       247
       +
                  }, tok.span

     

       248
       +
       

     

       249
       +
              | Token.Block_mapping_start when block ->

     

       250
       +
                  t.state <- Block_mapping_first_key;

     

       251
       +
                  skip_token t;

     

       252
       +
                  Event.Mapping_start {

     

       253
       +
                    anchor; tag;

     

       254
       +
                    implicit = tag = None;

     

       255
       +
                    style = Layout_style.Block;

     

       256
       +
                  }, tok.span

     

       257
       +
       

     

       258
       +
              | Token.Flow_sequence_start ->

     

       259
       +
                  t.state <- Flow_sequence_first_entry;

     

       260
       +
                  skip_token t;

     

       261
       +
                  Event.Sequence_start {

     

       262
       +
                    anchor; tag;

     

       263
       +
                    implicit = tag = None;

     

       264
       +
                    style = Layout_style.Flow;

     

       265
       +
                  }, tok.span

     

       266
       +
       

     

       267
       +
              | Token.Flow_mapping_start ->

     

       268
       +
                  t.state <- Flow_mapping_first_key;

     

       269
       +
                  skip_token t;

     

       270
       +
                  Event.Mapping_start {

     

       271
       +
                    anchor; tag;

     

       272
       +
                    implicit = tag = None;

     

       273
       +
                    style = Layout_style.Flow;

     

       274
       +
                  }, tok.span

     

       275
       +
       

     

       276
       +
              | Token.Scalar { style; value } ->

     

       277
       +
                  skip_token t;

     

       278
       +
                  t.state <- pop_state t;

     

       279
       +
                  let plain_implicit = tag = None && style = Scalar_style.Plain in

     

       280
       +
                  let quoted_implicit = tag = None && style <> Scalar_style.Plain in

     

       281
       +
                  Event.Scalar {

     

       282
       +
                    anchor; tag; value;

     

       283
       +
                    plain_implicit; quoted_implicit; style;

     

       284
       +
                  }, tok.span

     

       285
       +
       

     

       286
       +
              | _ ->

     

       287
       +
                  (* Empty node *)

     

       288
       +
                  t.state <- pop_state t;

     

       289
       +
                  empty_scalar_event ~anchor ~tag tok.span)

     

       290
       +
       

     

       291
       +
         | Token.Block_sequence_start when block ->

     

       292
       +
             t.state <- Block_sequence_first_entry;

     

       293
       +
             skip_token t;

     

       294
       +
             Event.Sequence_start {

     

       295
       +
               anchor = None; tag = None;

     

       296
       +
               implicit = true;

     

       297
       +
               style = Layout_style.Block;

     

       298
       +
             }, tok.span

     

       299
       +
       

     

       300
       +
         | Token.Block_mapping_start when block ->

     

       301
       +
             t.state <- Block_mapping_first_key;

     

       302
       +
             skip_token t;

     

       303
       +
             Event.Mapping_start {

     

       304
       +
               anchor = None; tag = None;

     

       305
       +
               implicit = true;

     

       306
       +
               style = Layout_style.Block;

     

       307
       +
             }, tok.span

     

       308
       +
       

     

       309
       +
         | Token.Flow_sequence_start ->

     

       310
       +
             t.state <- Flow_sequence_first_entry;

     

       311
       +
             skip_token t;

     

       312
       +
             Event.Sequence_start {

     

       313
       +
               anchor = None; tag = None;

     

       314
       +
               implicit = true;

     

       315
       +
               style = Layout_style.Flow;

     

       316
       +
             }, tok.span

     

       317
       +
       

     

       318
       +
         | Token.Flow_mapping_start ->

     

       319
       +
             t.state <- Flow_mapping_first_key;

     

       320
       +
             skip_token t;

     

       321
       +
             Event.Mapping_start {

     

       322
       +
               anchor = None; tag = None;

     

       323
       +
               implicit = true;

     

       324
       +
               style = Layout_style.Flow;

     

       325
       +
             }, tok.span

     

       326
       +
       

     

       327
       +
         | Token.Block_entry when indentless ->

     

       328
       +
             t.state <- Indentless_sequence_entry;

     

       329
       +
             Event.Sequence_start {

     

       330
       +
               anchor = None; tag = None;

     

       331
       +
               implicit = true;

     

       332
       +
               style = Layout_style.Block;

     

       333
       +
             }, tok.span

     

       334
       +
       

     

       335
       +
         | Token.Scalar { style; value } ->

     

       336
       +
             skip_token t;

     

       337
       +
             t.state <- pop_state t;

     

       338
       +
             let plain_implicit = style = Scalar_style.Plain in

     

       339
       +
             let quoted_implicit = style <> Scalar_style.Plain in

     

       340
       +
             Event.Scalar {

     

       341
       +
               anchor = None; tag = None; value;

     

       342
       +
               plain_implicit; quoted_implicit; style;

     

       343
       +
             }, tok.span

     

       344
       +
       

     

       345
       +
         | _ ->

     

       346
       +
             (* Empty node *)

     

       347
       +
             t.state <- pop_state t;

     

       348
       +
             empty_scalar_event ~anchor:None ~tag:None tok.span

     

       349
       +
       

     

       350
       +
       (** Parse block sequence entry *)

     

       351
       +
       let parse_block_sequence_entry t =

     

       352
       +
         let tok = current_token t in

     

       353
       +
         match tok.token with

     

       354
       +
         | Token.Block_entry ->

     

       355
       +
             skip_token t;

     

       356
       +
             if check t (function

     

       357
       +
               | Token.Block_entry | Token.Block_end -> true

     

       358
       +
               | _ -> false)

     

       359
       +
             then begin

     

       360
       +
               t.state <- Block_sequence_entry;

     

       361
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       362
       +
             end else begin

     

       363
       +
               push_state t Block_sequence_entry;

     

       364
       +
               parse_node t ~block:true ~indentless:false

     

       365
       +
             end

     

       366
       +
         | Token.Block_end ->

     

       367
       +
             skip_token t;

     

       368
       +
             t.state <- pop_state t;

     

       369
       +
             Event.Sequence_end, tok.span

     

       370
       +
         | _ ->

     

       371
       +
             Error.raise_span tok.span Expected_block_entry

     

       372
       +
       

     

       373
       +
       (** Parse block mapping key *)

     

       374
       +
       let parse_block_mapping_key t =

     

       375
       +
         let tok = current_token t in

     

       376
       +
         match tok.token with

     

       377
       +
         | Token.Key ->

     

       378
       +
             skip_token t;

     

       379
       +
             if check t (function

     

       380
       +
               | Token.Key | Token.Value | Token.Block_end -> true

     

       381
       +
               | _ -> false)

     

       382
       +
             then begin

     

       383
       +
               t.state <- Block_mapping_value;

     

       384
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       385
       +
             end else begin

     

       386
       +
               push_state t Block_mapping_value;

     

       387
       +
               parse_node t ~block:true ~indentless:true

     

       388
       +
             end

     

       389
       +
         | Token.Block_end ->

     

       390
       +
             skip_token t;

     

       391
       +
             t.state <- pop_state t;

     

       392
       +
             Event.Mapping_end, tok.span

     

       393
       +
         | _ ->

     

       394
       +
             Error.raise_span tok.span Expected_key

     

       395
       +
       

     

       396
       +
       (** Parse block mapping value *)

     

       397
       +
       let parse_block_mapping_value t =

     

       398
       +
         let tok = current_token t in

     

       399
       +
         match tok.token with

     

       400
       +
         | Token.Value ->

     

       401
       +
             skip_token t;

     

       402
       +
             if check t (function

     

       403
       +
               | Token.Key | Token.Value | Token.Block_end -> true

     

       404
       +
               | _ -> false)

     

       405
       +
             then begin

     

       406
       +
               t.state <- Block_mapping_key;

     

       407
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       408
       +
             end else begin

     

       409
       +
               push_state t Block_mapping_key;

     

       410
       +
               parse_node t ~block:true ~indentless:true

     

       411
       +
             end

     

       412
       +
         | _ ->

     

       413
       +
             (* Implicit empty value *)

     

       414
       +
             t.state <- Block_mapping_key;

     

       415
       +
             empty_scalar_event ~anchor:None ~tag:None tok.span

     

       416
       +
       

     

       417
       +
       (** Parse indentless sequence entry *)

     

       418
       +
       let parse_indentless_sequence_entry t =

     

       419
       +
         let tok = current_token t in

     

       420
       +
         match tok.token with

     

       421
       +
         | Token.Block_entry ->

     

       422
       +
             skip_token t;

     

       423
       +
             if check t (function

     

       424
       +
               | Token.Block_entry | Token.Key | Token.Value | Token.Block_end -> true

     

       425
       +
               | _ -> false)

     

       426
       +
             then begin

     

       427
       +
               t.state <- Indentless_sequence_entry;

     

       428
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       429
       +
             end else begin

     

       430
       +
               push_state t Indentless_sequence_entry;

     

       431
       +
               parse_node t ~block:true ~indentless:false

     

       432
       +
             end

     

       433
       +
         | _ ->

     

       434
       +
             t.state <- pop_state t;

     

       435
       +
             Event.Sequence_end, tok.span

     

       436
       +
       

     

       437
       +
       (** Parse flow sequence *)

     

       438
       +
       let rec parse_flow_sequence_entry t ~first =

     

       439
       +
         let tok = current_token t in

     

       440
       +
         match tok.token with

     

       441
       +
         | Token.Flow_sequence_end ->

     

       442
       +
             skip_token t;

     

       443
       +
             t.state <- pop_state t;

     

       444
       +
             Event.Sequence_end, tok.span

     

       445
       +
         | Token.Flow_entry when not first ->

     

       446
       +
             skip_token t;

     

       447
       +
             parse_flow_sequence_entry_internal t

     

       448
       +
         | _ when first ->

     

       449
       +
             parse_flow_sequence_entry_internal t

     

       450
       +
         | _ ->

     

       451
       +
             Error.raise_span tok.span Expected_sequence_end

     

       452
       +
       

     

       453
       +
       and parse_flow_sequence_entry_internal t =

     

       454
       +
         let tok = current_token t in

     

       455
       +
         match tok.token with

     

       456
       +
         | Token.Flow_sequence_end ->

     

       457
       +
             t.state <- Flow_sequence_entry;

     

       458
       +
             empty_scalar_event ~anchor:None ~tag:None tok.span

     

       459
       +
         | Token.Key ->

     

       460
       +
             skip_token t;

     

       461
       +
             push_state t Flow_sequence_entry_mapping_end;

     

       462
       +
             t.state <- Flow_sequence_entry_mapping_key;

     

       463
       +
             Event.Mapping_start {

     

       464
       +
               anchor = None; tag = None;

     

       465
       +
               implicit = true;

     

       466
       +
               style = Layout_style.Flow;

     

       467
       +
             }, tok.span

     

       468
       +
         | _ ->

     

       469
       +
             push_state t Flow_sequence_entry;

     

       470
       +
             parse_node t ~block:false ~indentless:false

     

       471
       +
       

     

       472
       +
       (** Parse flow sequence entry mapping *)

     

       473
       +
       let parse_flow_sequence_entry_mapping_key t =

     

       474
       +
         let tok = current_token t in

     

       475
       +
         if check t (function

     

       476
       +
           | Token.Value | Token.Flow_entry | Token.Flow_sequence_end -> true

     

       477
       +
           | _ -> false)

     

       478
       +
         then begin

     

       479
       +
           t.state <- Flow_sequence_entry_mapping_value;

     

       480
       +
           empty_scalar_event ~anchor:None ~tag:None tok.span

     

       481
       +
         end else begin

     

       482
       +
           push_state t Flow_sequence_entry_mapping_value;

     

       483
       +
           parse_node t ~block:false ~indentless:false

     

       484
       +
         end

     

       485
       +
       

     

       486
       +
       let parse_flow_sequence_entry_mapping_value t =

     

       487
       +
         let tok = current_token t in

     

       488
       +
         match tok.token with

     

       489
       +
         | Token.Value ->

     

       490
       +
             skip_token t;

     

       491
       +
             if check t (function

     

       492
       +
               | Token.Flow_entry | Token.Flow_sequence_end -> true

     

       493
       +
               | _ -> false)

     

       494
       +
             then begin

     

       495
       +
               t.state <- Flow_sequence_entry_mapping_end;

     

       496
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       497
       +
             end else begin

     

       498
       +
               push_state t Flow_sequence_entry_mapping_end;

     

       499
       +
               parse_node t ~block:false ~indentless:false

     

       500
       +
             end

     

       501
       +
         | _ ->

     

       502
       +
             t.state <- Flow_sequence_entry_mapping_end;

     

       503
       +
             empty_scalar_event ~anchor:None ~tag:None tok.span

     

       504
       +
       

     

       505
       +
       let parse_flow_sequence_entry_mapping_end t =

     

       506
       +
         let tok = current_token t in

     

       507
       +
         t.state <- Flow_sequence_entry;

     

       508
       +
         Event.Mapping_end, tok.span

     

       509
       +
       

     

       510
       +
       (** Parse flow mapping *)

     

       511
       +
       let rec parse_flow_mapping_key t ~first =

     

       512
       +
         let tok = current_token t in

     

       513
       +
         match tok.token with

     

       514
       +
         | Token.Flow_mapping_end ->

     

       515
       +
             skip_token t;

     

       516
       +
             t.state <- pop_state t;

     

       517
       +
             Event.Mapping_end, tok.span

     

       518
       +
         | Token.Flow_entry when not first ->

     

       519
       +
             skip_token t;

     

       520
       +
             parse_flow_mapping_key_internal t

     

       521
       +
         | _ when first ->

     

       522
       +
             parse_flow_mapping_key_internal t

     

       523
       +
         | _ ->

     

       524
       +
             Error.raise_span tok.span Expected_mapping_end

     

       525
       +
       

     

       526
       +
       and parse_flow_mapping_key_internal t =

     

       527
       +
         let tok = current_token t in

     

       528
       +
         match tok.token with

     

       529
       +
         | Token.Flow_mapping_end ->

     

       530
       +
             t.state <- Flow_mapping_key;

     

       531
       +
             empty_scalar_event ~anchor:None ~tag:None tok.span

     

       532
       +
         | Token.Key ->

     

       533
       +
             skip_token t;

     

       534
       +
             if check t (function

     

       535
       +
               | Token.Value | Token.Flow_entry | Token.Flow_mapping_end -> true

     

       536
       +
               | _ -> false)

     

       537
       +
             then begin

     

       538
       +
               t.state <- Flow_mapping_value;

     

       539
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       540
       +
             end else begin

     

       541
       +
               push_state t Flow_mapping_value;

     

       542
       +
               parse_node t ~block:false ~indentless:false

     

       543
       +
             end

     

       544
       +
         | _ ->

     

       545
       +
             push_state t Flow_mapping_value;

     

       546
       +
             parse_node t ~block:false ~indentless:false

     

       547
       +
       

     

       548
       +
       let parse_flow_mapping_value t ~empty =

     

       549
       +
         let tok = current_token t in

     

       550
       +
         if empty then begin

     

       551
       +
           t.state <- Flow_mapping_key;

     

       552
       +
           empty_scalar_event ~anchor:None ~tag:None tok.span

     

       553
       +
         end else

     

       554
       +
           match tok.token with

     

       555
       +
           | Token.Value ->

     

       556
       +
               skip_token t;

     

       557
       +
               if check t (function

     

       558
       +
                 | Token.Flow_entry | Token.Flow_mapping_end -> true

     

       559
       +
                 | _ -> false)

     

       560
       +
               then begin

     

       561
       +
                 t.state <- Flow_mapping_key;

     

       562
       +
                 empty_scalar_event ~anchor:None ~tag:None tok.span

     

       563
       +
               end else begin

     

       564
       +
                 push_state t Flow_mapping_key;

     

       565
       +
                 parse_node t ~block:false ~indentless:false

     

       566
       +
               end

     

       567
       +
           | _ ->

     

       568
       +
               t.state <- Flow_mapping_key;

     

       569
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       570
       +
       

     

       571
       +
       (** Main state machine dispatcher *)

     

       572
       +
       let parse t =

     

       573
       +
         match t.state with

     

       574
       +
         | Stream_start ->

     

       575
       +
             parse_stream_start t

     

       576
       +
       

     

       577
       +
         | Implicit_document_start ->

     

       578
       +
             if check t (function

     

       579
       +
               | Token.Version_directive _ | Token.Tag_directive _

     

       580
       +
               | Token.Document_start | Token.Stream_end -> true

     

       581
       +
               | _ -> false)

     

       582
       +
             then begin

     

       583
       +
               if check t (function Token.Stream_end -> true | _ -> false) then begin

     

       584
       +
                 let tok = current_token t in

     

       585
       +
                 skip_token t;

     

       586
       +
                 t.state <- End;

     

       587
       +
                 t.finished <- true;

     

       588
       +
                 Event.Stream_end, tok.span

     

       589
       +
               end else begin

     

       590
       +
                 parse_document_start t ~implicit:false

     

       591
       +
               end

     

       592
       +
             end else

     

       593
       +
               parse_document_start t ~implicit:true

     

       594
       +
       

     

       595
       +
         | Document_start ->

     

       596
       +
             parse_document_start t ~implicit:false

     

       597
       +
       

     

       598
       +
         | Document_content ->

     

       599
       +
             if check t (function

     

       600
       +
               | Token.Version_directive _ | Token.Tag_directive _

     

       601
       +
               | Token.Document_start | Token.Document_end | Token.Stream_end -> true

     

       602
       +
               | _ -> false)

     

       603
       +
             then begin

     

       604
       +
               let tok = current_token t in

     

       605
       +
               t.state <- pop_state t;

     

       606
       +
               empty_scalar_event ~anchor:None ~tag:None tok.span

     

       607
       +
             end else

     

       608
       +
               parse_node t ~block:true ~indentless:false

     

       609
       +
       

     

       610
       +
         | Document_end ->

     

       611
       +
             parse_document_end t

     

       612
       +
       

     

       613
       +
         | Block_node ->

     

       614
       +
             parse_node t ~block:true ~indentless:false

     

       615
       +
       

     

       616
       +
         | Block_node_or_indentless_sequence ->

     

       617
       +
             parse_node t ~block:true ~indentless:true

     

       618
       +
       

     

       619
       +
         | Flow_node ->

     

       620
       +
             parse_node t ~block:false ~indentless:false

     

       621
       +
       

     

       622
       +
         | Block_sequence_first_entry ->

     

       623
       +
             t.state <- Block_sequence_entry;

     

       624
       +
             parse_block_sequence_entry t

     

       625
       +
       

     

       626
       +
         | Block_sequence_entry ->

     

       627
       +
             parse_block_sequence_entry t

     

       628
       +
       

     

       629
       +
         | Indentless_sequence_entry ->

     

       630
       +
             parse_indentless_sequence_entry t

     

       631
       +
       

     

       632
       +
         | Block_mapping_first_key ->

     

       633
       +
             t.state <- Block_mapping_key;

     

       634
       +
             parse_block_mapping_key t

     

       635
       +
       

     

       636
       +
         | Block_mapping_key ->

     

       637
       +
             parse_block_mapping_key t

     

       638
       +
       

     

       639
       +
         | Block_mapping_value ->

     

       640
       +
             parse_block_mapping_value t

     

       641
       +
       

     

       642
       +
         | Flow_sequence_first_entry ->

     

       643
       +
             parse_flow_sequence_entry t ~first:true

     

       644
       +
       

     

       645
       +
         | Flow_sequence_entry ->

     

       646
       +
             parse_flow_sequence_entry t ~first:false

     

       647
       +
       

     

       648
       +
         | Flow_sequence_entry_mapping_key ->

     

       649
       +
             parse_flow_sequence_entry_mapping_key t

     

       650
       +
       

     

       651
       +
         | Flow_sequence_entry_mapping_value ->

     

       652
       +
             parse_flow_sequence_entry_mapping_value t

     

       653
       +
       

     

       654
       +
         | Flow_sequence_entry_mapping_end ->

     

       655
       +
             parse_flow_sequence_entry_mapping_end t

     

       656
       +
       

     

       657
       +
         | Flow_mapping_first_key ->

     

       658
       +
             parse_flow_mapping_key t ~first:true

     

       659
       +
       

     

       660
       +
         | Flow_mapping_key ->

     

       661
       +
             parse_flow_mapping_key t ~first:false

     

       662
       +
       

     

       663
       +
         | Flow_mapping_value ->

     

       664
       +
             parse_flow_mapping_value t ~empty:false

     

       665
       +
       

     

       666
       +
         | Flow_mapping_empty_value ->

     

       667
       +
             parse_flow_mapping_value t ~empty:true

     

       668
       +
       

     

       669
       +
         | End ->

     

       670
       +
             let span = Span.point Position.initial in

     

       671
       +
             t.finished <- true;

     

       672
       +
             Event.Stream_end, span

     

       673
       +
       

     

       674
       +
       (** Get next event *)

     

       675
       +
       let next t =

     

       676
       +
         if t.finished then None

     

       677
       +
         else begin

     

       678
       +
           let event, span = parse t in

     

       679
       +
           Some { Event.event; span }

     

       680
       +
         end

     

       681
       +
       

     

       682
       +
       (** Peek at next event *)

     

       683
       +
       let peek t =

     

       684
       +
         (* Parser is not easily peekable without full state save/restore *)

     

       685
       +
         (* For now, we don't support peek - could add caching if needed *)

     

       686
       +
         if t.finished then None

     

       687
       +
         else

     

       688
       +
           (* Just call next and the caller will have to deal with it *)

     

       689
       +
           next t

     

       690
       +
       

     

       691
       +
       (** Iterate over all events *)

     

       692
       +
       let iter f t =

     

       693
       +
         let rec loop () =

     

       694
       +
           match next t with

     

       695
       +
           | None -> ()

     

       696
       +
           | Some ev -> f ev; loop ()

     

       697
       +
         in

     

       698
       +
         loop ()

     

       699
       +
       

     

       700
       +
       (** Fold over all events *)

     

       701
       +
       let fold f init t =

     

       702
       +
         let rec loop acc =

     

       703
       +
           match next t with

     

       704
       +
           | None -> acc

     

       705
       +
           | Some ev -> loop (f acc ev)

     

       706
       +
         in

     

       707
       +
         loop init

     

       708
       +
       

     

       709
       +
       (** Convert to list *)

     

       710
       +
       let to_list t =

     

       711
       +
         fold (fun acc ev -> ev :: acc) [] t |> List.rev

+42

yaml/ocaml-yamle/lib/position.ml

···

       1
       +
       (** Position tracking for source locations *)

     

       2
       +
       

     

       3
       +
       type t = {

     

       4
       +
         index : int;   (** Byte offset from start *)

     

       5
       +
         line : int;    (** 1-indexed line number *)

     

       6
       +
         column : int;  (** 1-indexed column number *)

     

       7
       +
       }

     

       8
       +
       

     

       9
       +
       let initial = { index = 0; line = 1; column = 1 }

     

       10
       +
       

     

       11
       +
       let advance_byte t =

     

       12
       +
         { t with index = t.index + 1; column = t.column + 1 }

     

       13
       +
       

     

       14
       +
       let advance_line t =

     

       15
       +
         { index = t.index + 1; line = t.line + 1; column = 1 }

     

       16
       +
       

     

       17
       +
       let advance_char c t =

     

       18
       +
         if c = '\n' then advance_line t

     

       19
       +
         else advance_byte t

     

       20
       +
       

     

       21
       +
       let advance_utf8 uchar t =

     

       22
       +
         let len = Uchar.utf_8_byte_length uchar in

     

       23
       +
         let code = Uchar.to_int uchar in

     

       24
       +
         if code = 0x0A (* LF *) then

     

       25
       +
           { index = t.index + len; line = t.line + 1; column = 1 }

     

       26
       +
         else

     

       27
       +
           { t with index = t.index + len; column = t.column + 1 }

     

       28
       +
       

     

       29
       +
       let advance_bytes n t =

     

       30
       +
         { t with index = t.index + n; column = t.column + n }

     

       31
       +
       

     

       32
       +
       let pp fmt t =

     

       33
       +
         Format.fprintf fmt "line %d, column %d" t.line t.column

     

       34
       +
       

     

       35
       +
       let to_string t =

     

       36
       +
         Format.asprintf "%a" pp t

     

       37
       +
       

     

       38
       +
       let compare a b =

     

       39
       +
         Int.compare a.index b.index

     

       40
       +
       

     

       41
       +
       let equal a b =

     

       42
       +
         a.index = b.index

+61

yaml/ocaml-yamle/lib/scalar.ml

···

       1
       +
       (** YAML scalar values with metadata *)

     

       2
       +
       

     

       3
       +
       type t = {

     

       4
       +
         anchor : string option;

     

       5
       +
         tag : string option;

     

       6
       +
         value : string;

     

       7
       +
         plain_implicit : bool;

     

       8
       +
         quoted_implicit : bool;

     

       9
       +
         style : Scalar_style.t;

     

       10
       +
       }

     

       11
       +
       

     

       12
       +
       let make

     

       13
       +
           ?(anchor : string option)

     

       14
       +
           ?(tag : string option)

     

       15
       +
           ?(plain_implicit = true)

     

       16
       +
           ?(quoted_implicit = false)

     

       17
       +
           ?(style = Scalar_style.Plain)

     

       18
       +
           value =

     

       19
       +
         { anchor; tag; value; plain_implicit; quoted_implicit; style }

     

       20
       +
       

     

       21
       +
       let value t = t.value

     

       22
       +
       let anchor t = t.anchor

     

       23
       +
       let tag t = t.tag

     

       24
       +
       let style t = t.style

     

       25
       +
       let plain_implicit t = t.plain_implicit

     

       26
       +
       let quoted_implicit t = t.quoted_implicit

     

       27
       +
       

     

       28
       +
       let with_anchor anchor t = { t with anchor = Some anchor }

     

       29
       +
       let with_tag tag t = { t with tag = Some tag }

     

       30
       +
       let with_style style t = { t with style }

     

       31
       +
       

     

       32
       +
       let pp fmt t =

     

       33
       +
         Format.fprintf fmt "scalar(%S" t.value;

     

       34
       +
         (match t.anchor with

     

       35
       +
          | Some a -> Format.fprintf fmt ", anchor=%s" a

     

       36
       +
          | None -> ());

     

       37
       +
         (match t.tag with

     

       38
       +
          | Some tag -> Format.fprintf fmt ", tag=%s" tag

     

       39
       +
          | None -> ());

     

       40
       +
         Format.fprintf fmt ", style=%a)" Scalar_style.pp t.style

     

       41
       +
       

     

       42
       +
       let equal a b =

     

       43
       +
         Option.equal String.equal a.anchor b.anchor &&

     

       44
       +
         Option.equal String.equal a.tag b.tag &&

     

       45
       +
         String.equal a.value b.value &&

     

       46
       +
         a.plain_implicit = b.plain_implicit &&

     

       47
       +
         a.quoted_implicit = b.quoted_implicit &&

     

       48
       +
         Scalar_style.equal a.style b.style

     

       49
       +
       

     

       50
       +
       let compare a b =

     

       51
       +
         let c = Option.compare String.compare a.anchor b.anchor in

     

       52
       +
         if c <> 0 then c else

     

       53
       +
         let c = Option.compare String.compare a.tag b.tag in

     

       54
       +
         if c <> 0 then c else

     

       55
       +
         let c = String.compare a.value b.value in

     

       56
       +
         if c <> 0 then c else

     

       57
       +
         let c = Bool.compare a.plain_implicit b.plain_implicit in

     

       58
       +
         if c <> 0 then c else

     

       59
       +
         let c = Bool.compare a.quoted_implicit b.quoted_implicit in

     

       60
       +
         if c <> 0 then c else

     

       61
       +
         Scalar_style.compare a.style b.style

+33

yaml/ocaml-yamle/lib/scalar_style.ml

···

       1
       +
       (** Scalar formatting styles *)

     

       2
       +
       

     

       3
       +
       type t =

     

       4
       +
         | Any           (** Let emitter choose *)

     

       5
       +
         | Plain         (** Unquoted: foo *)

     

       6
       +
         | Single_quoted (** 'foo' *)

     

       7
       +
         | Double_quoted (** "foo" *)

     

       8
       +
         | Literal       (** | block *)

     

       9
       +
         | Folded        (** > block *)

     

       10
       +
       

     

       11
       +
       let to_string = function

     

       12
       +
         | Any -> "any"

     

       13
       +
         | Plain -> "plain"

     

       14
       +
         | Single_quoted -> "single-quoted"

     

       15
       +
         | Double_quoted -> "double-quoted"

     

       16
       +
         | Literal -> "literal"

     

       17
       +
         | Folded -> "folded"

     

       18
       +
       

     

       19
       +
       let pp fmt t =

     

       20
       +
         Format.pp_print_string fmt (to_string t)

     

       21
       +
       

     

       22
       +
       let equal a b = a = b

     

       23
       +
       

     

       24
       +
       let compare a b =

     

       25
       +
         let to_int = function

     

       26
       +
           | Any -> 0

     

       27
       +
           | Plain -> 1

     

       28
       +
           | Single_quoted -> 2

     

       29
       +
           | Double_quoted -> 3

     

       30
       +
           | Literal -> 4

     

       31
       +
           | Folded -> 5

     

       32
       +
         in

     

       33
       +
         Int.compare (to_int a) (to_int b)

+1046

yaml/ocaml-yamle/lib/scanner.ml

···

       1
       +
       (** YAML tokenizer/scanner with lookahead for ambiguity resolution *)

     

       2
       +
       

     

       3
       +
       (** Simple key tracking for mapping key disambiguation *)

     

       4
       +
       type simple_key = {

     

       5
       +
         sk_possible : bool;

     

       6
       +
         sk_required : bool;

     

       7
       +
         sk_token_number : int;

     

       8
       +
         sk_position : Position.t;

     

       9
       +
       }

     

       10
       +
       

     

       11
       +
       (** Indent level tracking *)

     

       12
       +
       type indent = {

     

       13
       +
         indent : int;

     

       14
       +
         needs_block_end : bool;

     

       15
       +
         sequence : bool;  (** true if this is a sequence indent *)

     

       16
       +
       }

     

       17
       +
       

     

       18
       +
       type t = {

     

       19
       +
         input : Input.t;

     

       20
       +
         mutable tokens : Token.spanned Queue.t;

     

       21
       +
         mutable token_number : int;

     

       22
       +
         mutable tokens_taken : int;

     

       23
       +
         mutable stream_started : bool;

     

       24
       +
         mutable stream_ended : bool;

     

       25
       +
         mutable indent_stack : indent list;  (** Stack of indentation levels *)

     

       26
       +
         mutable flow_level : int;            (** Nesting depth in [] or {} *)

     

       27
       +
         mutable simple_keys : simple_key option list;  (** Per flow-level simple key tracking *)

     

       28
       +
         mutable allow_simple_key : bool;

     

       29
       +
       }

     

       30
       +
       

     

       31
       +
       let create input =

     

       32
       +
         {

     

       33
       +
           input;

     

       34
       +
           tokens = Queue.create ();

     

       35
       +
           token_number = 0;

     

       36
       +
           tokens_taken = 0;

     

       37
       +
           stream_started = false;

     

       38
       +
           stream_ended = false;

     

       39
       +
           indent_stack = [];

     

       40
       +
           flow_level = 0;

     

       41
       +
           simple_keys = [None];  (* One entry for the base level *)

     

       42
       +
           allow_simple_key = true;

     

       43
       +
         }

     

       44
       +
       

     

       45
       +
       let of_string s = create (Input.of_string s)

     

       46
       +
       

     

       47
       +
       let position t = Input.position t.input

     

       48
       +
       

     

       49
       +
       (** Add a token to the queue *)

     

       50
       +
       let emit t span token =

     

       51
       +
         Queue.add { Token.token; span } t.tokens;

     

       52
       +
         t.token_number <- t.token_number + 1

     

       53
       +
       

     

       54
       +
       (** Get current column (1-indexed) *)

     

       55
       +
       let column t = (Input.position t.input).column

     

       56
       +
       

     

       57
       +
       (** Get current indent level *)

     

       58
       +
       let current_indent t =

     

       59
       +
         match t.indent_stack with

     

       60
       +
         | [] -> 0

     

       61
       +
         | { indent; _ } :: _ -> indent

     

       62
       +
       

     

       63
       +
       (** Skip whitespace and comments, return true if at newline *)

     

       64
       +
       let rec skip_to_next_token t =

     

       65
       +
         (* Skip blanks *)

     

       66
       +
         while Input.next_is_blank t.input do

     

       67
       +
           ignore (Input.next t.input)

     

       68
       +
         done;

     

       69
       +
         (* Skip comment *)

     

       70
       +
         if Input.next_is (( = ) '#') t.input then begin

     

       71
       +
           while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do

     

       72
       +
             ignore (Input.next t.input)

     

       73
       +
           done

     

       74
       +
         end;

     

       75
       +
         (* Skip line break in block context *)

     

       76
       +
         if t.flow_level = 0 && Input.next_is_break t.input then begin

     

       77
       +
           Input.consume_break t.input;

     

       78
       +
           t.allow_simple_key <- true;

     

       79
       +
           skip_to_next_token t

     

       80
       +
         end

     

       81
       +
         else if t.flow_level > 0 && Input.next_is_whitespace t.input then begin

     

       82
       +
           ignore (Input.next t.input);

     

       83
       +
           skip_to_next_token t

     

       84
       +
         end

     

       85
       +
       

     

       86
       +
       (** Roll the indentation level *)

     

       87
       +
       let roll_indent t col ~sequence =

     

       88
       +
         if t.flow_level = 0 && col > current_indent t then begin

     

       89
       +
           t.indent_stack <- { indent = col; needs_block_end = true; sequence } :: t.indent_stack;

     

       90
       +
           true

     

       91
       +
         end else

     

       92
       +
           false

     

       93
       +
       

     

       94
       +
       (** Unroll indentation to given column *)

     

       95
       +
       let unroll_indent t col =

     

       96
       +
         while t.flow_level = 0 &&

     

       97
       +
               match t.indent_stack with

     

       98
       +
               | { indent; needs_block_end = true; _ } :: _ when indent > col -> true

     

       99
       +
               | _ -> false

     

       100
       +
         do

     

       101
       +
           match t.indent_stack with

     

       102
       +
           | { indent = _; needs_block_end = true; _ } :: rest ->

     

       103
       +
               let pos = Input.position t.input in

     

       104
       +
               let span = Span.point pos in

     

       105
       +
               emit t span Token.Block_end;

     

       106
       +
               t.indent_stack <- rest

     

       107
       +
           | _ -> ()

     

       108
       +
         done

     

       109
       +
       

     

       110
       +
       (** Save a potential simple key *)

     

       111
       +
       let save_simple_key t =

     

       112
       +
         if t.allow_simple_key then begin

     

       113
       +
           (* A simple key is required only if we're in a block context,

     

       114
       +
              at the current indentation level, AND we have an active indent *)

     

       115
       +
           let required = t.flow_level = 0 &&

     

       116
       +
                          t.indent_stack <> [] &&

     

       117
       +
                          current_indent t = column t - 1 in

     

       118
       +
           let sk = {

     

       119
       +
             sk_possible = true;

     

       120
       +
             sk_required = required;

     

       121
       +
             sk_token_number = t.token_number;

     

       122
       +
             sk_position = Input.position t.input;

     

       123
       +
           } in

     

       124
       +
           (* Remove any existing simple key at current level *)

     

       125
       +
           t.simple_keys <- (

     

       126
       +
             match t.simple_keys with

     

       127
       +
             | _ :: rest -> Some sk :: rest

     

       128
       +
             | [] -> [Some sk]

     

       129
       +
           )

     

       130
       +
         end

     

       131
       +
       

     

       132
       +
       (** Remove simple key at current level *)

     

       133
       +
       let remove_simple_key t =

     

       134
       +
         match t.simple_keys with

     

       135
       +
         | Some sk :: _rest when sk.sk_required ->

     

       136
       +
             Error.raise_at sk.sk_position Expected_key

     

       137
       +
         | _ :: rest -> t.simple_keys <- None :: rest

     

       138
       +
         | [] -> ()

     

       139
       +
       

     

       140
       +
       (** Stale simple keys that span too many tokens *)

     

       141
       +
       let stale_simple_keys t =

     

       142
       +
         t.simple_keys <- List.map (fun sk_opt ->

     

       143
       +
           match sk_opt with

     

       144
       +
           | Some sk when sk.sk_possible &&

     

       145
       +
                          (Input.position t.input).line > sk.sk_position.line &&

     

       146
       +
                          t.flow_level = 0 ->

     

       147
       +
               if sk.sk_required then

     

       148
       +
                 Error.raise_at sk.sk_position Expected_key;

     

       149
       +
               None

     

       150
       +
           | _ -> sk_opt

     

       151
       +
         ) t.simple_keys

     

       152
       +
       

     

       153
       +
       (** Read anchor or alias name *)

     

       154
       +
       let scan_anchor_alias t =

     

       155
       +
         let start = Input.mark t.input in

     

       156
       +
         let buf = Buffer.create 16 in

     

       157
       +
         while

     

       158
       +
           match Input.peek t.input with

     

       159
       +
           | Some c when Input.is_alnum c || c = '_' || c = '-' ->

     

       160
       +
               Buffer.add_char buf c;

     

       161
       +
               ignore (Input.next t.input);

     

       162
       +
               true

     

       163
       +
           | _ -> false

     

       164
       +
         do () done;

     

       165
       +
         let name = Buffer.contents buf in

     

       166
       +
         if String.length name = 0 then

     

       167
       +
           Error.raise_at start (Invalid_anchor "empty anchor name");

     

       168
       +
         (name, Span.make ~start ~stop:(Input.mark t.input))

     

       169
       +
       

     

       170
       +
       (** Scan tag handle *)

     

       171
       +
       let scan_tag_handle t =

     

       172
       +
         let start = Input.mark t.input in

     

       173
       +
         let buf = Buffer.create 16 in

     

       174
       +
         (* Expect ! *)

     

       175
       +
         (match Input.peek t.input with

     

       176
       +
          | Some '!' ->

     

       177
       +
              Buffer.add_char buf '!';

     

       178
       +
              ignore (Input.next t.input)

     

       179
       +
          | _ -> Error.raise_at start (Invalid_tag "expected '!'"));

     

       180
       +
         (* Read word chars *)

     

       181
       +
         while

     

       182
       +
           match Input.peek t.input with

     

       183
       +
           | Some c when Input.is_alnum c || c = '-' ->

     

       184
       +
               Buffer.add_char buf c;

     

       185
       +
               ignore (Input.next t.input);

     

       186
       +
               true

     

       187
       +
           | _ -> false

     

       188
       +
         do () done;

     

       189
       +
         (* Check for secondary ! *)

     

       190
       +
         (match Input.peek t.input with

     

       191
       +
          | Some '!' ->

     

       192
       +
              Buffer.add_char buf '!';

     

       193
       +
              ignore (Input.next t.input)

     

       194
       +
          | _ -> ());

     

       195
       +
         Buffer.contents buf

     

       196
       +
       

     

       197
       +
       (** Scan tag suffix (after handle) *)

     

       198
       +
       let scan_tag_suffix t =

     

       199
       +
         let buf = Buffer.create 32 in

     

       200
       +
         while

     

       201
       +
           match Input.peek t.input with

     

       202
       +
           | Some c when not (Input.is_whitespace c) &&

     

       203
       +
                         not (Input.is_flow_indicator c) ->

     

       204
       +
               Buffer.add_char buf c;

     

       205
       +
               ignore (Input.next t.input);

     

       206
       +
               true

     

       207
       +
           | _ -> false

     

       208
       +
         do () done;

     

       209
       +
         Buffer.contents buf

     

       210
       +
       

     

       211
       +
       (** Scan a tag *)

     

       212
       +
       let scan_tag t =

     

       213
       +
         let start = Input.mark t.input in

     

       214
       +
         ignore (Input.next t.input); (* consume ! *)

     

       215
       +
         let handle, suffix =

     

       216
       +
           match Input.peek t.input with

     

       217
       +
           | Some '<' ->

     

       218
       +
               (* Verbatim tag: !<...> *)

     

       219
       +
               ignore (Input.next t.input);

     

       220
       +
               let buf = Buffer.create 32 in

     

       221
       +
               while

     

       222
       +
                 match Input.peek t.input with

     

       223
       +
                 | Some '>' -> false

     

       224
       +
                 | Some c ->

     

       225
       +
                     Buffer.add_char buf c;

     

       226
       +
                     ignore (Input.next t.input);

     

       227
       +
                     true

     

       228
       +
                 | None -> Error.raise_at (Input.mark t.input) (Invalid_tag "unclosed verbatim tag")

     

       229
       +
               do () done;

     

       230
       +
               ignore (Input.next t.input); (* consume > *)

     

       231
       +
               ("!", Buffer.contents buf)

     

       232
       +
           | Some c when Input.is_whitespace c || Input.is_flow_indicator c ->

     

       233
       +
               (* Non-specific tag: ! *)

     

       234
       +
               ("!", "")

     

       235
       +
           | Some '!' ->

     

       236
       +
               (* Secondary handle *)

     

       237
       +
               let handle = scan_tag_handle t in

     

       238
       +
               let suffix = scan_tag_suffix t in

     

       239
       +
               (handle, suffix)

     

       240
       +
           | _ ->

     

       241
       +
               (* Primary handle or just suffix *)

     

       242
       +
               let first_part = scan_tag_suffix t in

     

       243
       +
               if String.length first_part > 0 && first_part.[String.length first_part - 1] = '!' then

     

       244
       +
                 let suffix = scan_tag_suffix t in

     

       245
       +
                 (first_part, suffix)

     

       246
       +
               else

     

       247
       +
                 ("!", first_part)

     

       248
       +
         in

     

       249
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       250
       +
         (handle, suffix, span)

     

       251
       +
       

     

       252
       +
       (** Scan single-quoted scalar *)

     

       253
       +
       let scan_single_quoted t =

     

       254
       +
         let start = Input.mark t.input in

     

       255
       +
         ignore (Input.next t.input); (* consume opening single-quote *)

     

       256
       +
         let buf = Buffer.create 64 in

     

       257
       +
         let rec loop () =

     

       258
       +
           match Input.peek t.input with

     

       259
       +
           | None -> Error.raise_at start Unclosed_single_quote

     

       260
       +
           | Some '\'' ->

     

       261
       +
               ignore (Input.next t.input);

     

       262
       +
               (* Check for escaped quote ('') *)

     

       263
       +
               (match Input.peek t.input with

     

       264
       +
                | Some '\'' ->

     

       265
       +
                    Buffer.add_char buf '\'';

     

       266
       +
                    ignore (Input.next t.input);

     

       267
       +
                    loop ()

     

       268
       +
                | _ -> ())

     

       269
       +
           | Some '\n' | Some '\r' ->

     

       270
       +
               Input.consume_break t.input;

     

       271
       +
               (* Fold line break to space unless at start of content *)

     

       272
       +
               if Buffer.length buf > 0 then

     

       273
       +
                 Buffer.add_char buf ' ';

     

       274
       +
               (* Skip leading whitespace on next line *)

     

       275
       +
               while Input.next_is_blank t.input do

     

       276
       +
                 ignore (Input.next t.input)

     

       277
       +
               done;

     

       278
       +
               loop ()

     

       279
       +
           | Some c ->

     

       280
       +
               Buffer.add_char buf c;

     

       281
       +
               ignore (Input.next t.input);

     

       282
       +
               loop ()

     

       283
       +
         in

     

       284
       +
         loop ();

     

       285
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       286
       +
         (Buffer.contents buf, span)

     

       287
       +
       

     

       288
       +
       (** Decode hex escape of given length *)

     

       289
       +
       let decode_hex t len =

     

       290
       +
         let start = Input.mark t.input in

     

       291
       +
         let buf = Buffer.create len in

     

       292
       +
         for _ = 1 to len do

     

       293
       +
           match Input.peek t.input with

     

       294
       +
           | Some c when Input.is_hex c ->

     

       295
       +
               Buffer.add_char buf c;

     

       296
       +
               ignore (Input.next t.input)

     

       297
       +
           | _ ->

     

       298
       +
               Error.raise_at start (Invalid_hex_escape (Buffer.contents buf))

     

       299
       +
         done;

     

       300
       +
         let code = int_of_string ("0x" ^ Buffer.contents buf) in

     

       301
       +
         if code <= 0x7F then

     

       302
       +
           String.make 1 (Char.chr code)

     

       303
       +
         else if code <= 0x7FF then

     

       304
       +
           let b1 = 0xC0 lor (code lsr 6) in

     

       305
       +
           let b2 = 0x80 lor (code land 0x3F) in

     

       306
       +
           String.init 2 (fun i -> Char.chr (if i = 0 then b1 else b2))

     

       307
       +
         else if code <= 0xFFFF then

     

       308
       +
           let b1 = 0xE0 lor (code lsr 12) in

     

       309
       +
           let b2 = 0x80 lor ((code lsr 6) land 0x3F) in

     

       310
       +
           let b3 = 0x80 lor (code land 0x3F) in

     

       311
       +
           String.init 3 (fun i -> Char.chr (match i with 0 -> b1 | 1 -> b2 | _ -> b3))

     

       312
       +
         else

     

       313
       +
           let b1 = 0xF0 lor (code lsr 18) in

     

       314
       +
           let b2 = 0x80 lor ((code lsr 12) land 0x3F) in

     

       315
       +
           let b3 = 0x80 lor ((code lsr 6) land 0x3F) in

     

       316
       +
           let b4 = 0x80 lor (code land 0x3F) in

     

       317
       +
           String.init 4 (fun i -> Char.chr (match i with 0 -> b1 | 1 -> b2 | 2 -> b3 | _ -> b4))

     

       318
       +
       

     

       319
       +
       (** Scan double-quoted scalar *)

     

       320
       +
       let scan_double_quoted t =

     

       321
       +
         let start = Input.mark t.input in

     

       322
       +
         ignore (Input.next t.input); (* consume opening double-quote *)

     

       323
       +
         let buf = Buffer.create 64 in

     

       324
       +
         let rec loop () =

     

       325
       +
           match Input.peek t.input with

     

       326
       +
           | None -> Error.raise_at start Unclosed_double_quote

     

       327
       +
           | Some '"' ->

     

       328
       +
               ignore (Input.next t.input)

     

       329
       +
           | Some '\\' ->

     

       330
       +
               ignore (Input.next t.input);

     

       331
       +
               (match Input.peek t.input with

     

       332
       +
                | None -> Error.raise_at start (Invalid_escape_sequence "\\<EOF>")

     

       333
       +
                | Some '0' -> Buffer.add_char buf '\x00'; ignore (Input.next t.input)

     

       334
       +
                | Some 'a' -> Buffer.add_char buf '\x07'; ignore (Input.next t.input)

     

       335
       +
                | Some 'b' -> Buffer.add_char buf '\x08'; ignore (Input.next t.input)

     

       336
       +
                | Some 't' | Some '\t' -> Buffer.add_char buf '\t'; ignore (Input.next t.input)

     

       337
       +
                | Some 'n' -> Buffer.add_char buf '\n'; ignore (Input.next t.input)

     

       338
       +
                | Some 'v' -> Buffer.add_char buf '\x0B'; ignore (Input.next t.input)

     

       339
       +
                | Some 'f' -> Buffer.add_char buf '\x0C'; ignore (Input.next t.input)

     

       340
       +
                | Some 'r' -> Buffer.add_char buf '\r'; ignore (Input.next t.input)

     

       341
       +
                | Some 'e' -> Buffer.add_char buf '\x1B'; ignore (Input.next t.input)

     

       342
       +
                | Some ' ' -> Buffer.add_char buf ' '; ignore (Input.next t.input)

     

       343
       +
                | Some '"' -> Buffer.add_char buf '"'; ignore (Input.next t.input)

     

       344
       +
                | Some '/' -> Buffer.add_char buf '/'; ignore (Input.next t.input)

     

       345
       +
                | Some '\\' -> Buffer.add_char buf '\\'; ignore (Input.next t.input)

     

       346
       +
                | Some 'N' -> Buffer.add_string buf "\xC2\x85"; ignore (Input.next t.input) (* NEL *)

     

       347
       +
                | Some '_' -> Buffer.add_string buf "\xC2\xA0"; ignore (Input.next t.input) (* NBSP *)

     

       348
       +
                | Some 'L' -> Buffer.add_string buf "\xE2\x80\xA8"; ignore (Input.next t.input) (* LS *)

     

       349
       +
                | Some 'P' -> Buffer.add_string buf "\xE2\x80\xA9"; ignore (Input.next t.input) (* PS *)

     

       350
       +
                | Some 'x' ->

     

       351
       +
                    ignore (Input.next t.input);

     

       352
       +
                    Buffer.add_string buf (decode_hex t 2)

     

       353
       +
                | Some 'u' ->

     

       354
       +
                    ignore (Input.next t.input);

     

       355
       +
                    Buffer.add_string buf (decode_hex t 4)

     

       356
       +
                | Some 'U' ->

     

       357
       +
                    ignore (Input.next t.input);

     

       358
       +
                    Buffer.add_string buf (decode_hex t 8)

     

       359
       +
                | Some '\n' | Some '\r' ->

     

       360
       +
                    (* Line continuation *)

     

       361
       +
                    Input.consume_break t.input;

     

       362
       +
                    while Input.next_is_blank t.input do

     

       363
       +
                      ignore (Input.next t.input)

     

       364
       +
                    done

     

       365
       +
                | Some c ->

     

       366
       +
                    Error.raise_at (Input.mark t.input)

     

       367
       +
                      (Invalid_escape_sequence (Printf.sprintf "\\%c" c)));

     

       368
       +
               loop ()

     

       369
       +
           | Some '\n' | Some '\r' ->

     

       370
       +
               Input.consume_break t.input;

     

       371
       +
               (* Fold to space *)

     

       372
       +
               Buffer.add_char buf ' ';

     

       373
       +
               (* Skip leading whitespace *)

     

       374
       +
               while Input.next_is_blank t.input do

     

       375
       +
                 ignore (Input.next t.input)

     

       376
       +
               done;

     

       377
       +
               loop ()

     

       378
       +
           | Some c ->

     

       379
       +
               Buffer.add_char buf c;

     

       380
       +
               ignore (Input.next t.input);

     

       381
       +
               loop ()

     

       382
       +
         in

     

       383
       +
         loop ();

     

       384
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       385
       +
         (Buffer.contents buf, span)

     

       386
       +
       

     

       387
       +
       (** Check if character can appear in plain scalar at this position *)

     

       388
       +
       let can_continue_plain t c ~in_flow =

     

       389
       +
         match c with

     

       390
       +
         | ':' ->

     

       391
       +
             (* : is OK if not followed by whitespace or flow indicator *)

     

       392
       +
             (match Input.peek_nth t.input 1 with

     

       393
       +
              | None -> true

     

       394
       +
              | Some c2 when Input.is_whitespace c2 -> false

     

       395
       +
              | Some c2 when in_flow && Input.is_flow_indicator c2 -> false

     

       396
       +
              | _ -> true)

     

       397
       +
         | '#' ->

     

       398
       +
             (* # is OK if not preceded by whitespace (checked at call site) *)

     

       399
       +
             false

     

       400
       +
         | c when in_flow && Input.is_flow_indicator c -> false

     

       401
       +
         | _ when Input.is_break c -> false

     

       402
       +
         | _ -> true

     

       403
       +
       

     

       404
       +
       (** Scan plain scalar *)

     

       405
       +
       let scan_plain_scalar t =

     

       406
       +
         let start = Input.mark t.input in

     

       407
       +
         let in_flow = t.flow_level > 0 in

     

       408
       +
         let indent = current_indent t in

     

       409
       +
         let buf = Buffer.create 64 in

     

       410
       +
         let spaces = Buffer.create 16 in

     

       411
       +
         let leading_blanks = ref false in

     

       412
       +
       

     

       413
       +
         let rec scan_line () =

     

       414
       +
           match Input.peek t.input with

     

       415
       +
           | None -> ()

     

       416
       +
           | Some c when can_continue_plain t c ~in_flow ->

     

       417
       +
               (* Check for # preceded by space *)

     

       418
       +
               if c = '#' && Buffer.length buf > 0 then

     

       419
       +
                 ()  (* Stop - # after content *)

     

       420
       +
               else begin

     

       421
       +
                 if Buffer.length spaces > 0 then begin

     

       422
       +
                   if !leading_blanks then begin

     

       423
       +
                     (* Fold line break *)

     

       424
       +
                     if Buffer.contents spaces = "\n" then

     

       425
       +
                       Buffer.add_char buf ' '

     

       426
       +
                     else begin

     

       427
       +
                       (* Multiple breaks - preserve all but first *)

     

       428
       +
                       let s = Buffer.contents spaces in

     

       429
       +
                       Buffer.add_substring buf s 1 (String.length s - 1)

     

       430
       +
                     end

     

       431
       +
                   end else

     

       432
       +
                     Buffer.add_buffer buf spaces;

     

       433
       +
                   Buffer.clear spaces

     

       434
       +
                 end;

     

       435
       +
                 Buffer.add_char buf c;

     

       436
       +
                 ignore (Input.next t.input);

     

       437
       +
                 leading_blanks := false;

     

       438
       +
                 scan_line ()

     

       439
       +
               end

     

       440
       +
           | _ -> ()

     

       441
       +
         in

     

       442
       +
       

     

       443
       +
         let rec scan_lines () =

     

       444
       +
           scan_line ();

     

       445
       +
           (* Check for line continuation *)

     

       446
       +
           if not in_flow && Input.next_is_break t.input then begin

     

       447
       +
             (* Save whitespace *)

     

       448
       +
             Buffer.clear spaces;

     

       449
       +
             Buffer.add_char spaces '\n';

     

       450
       +
             Input.consume_break t.input;

     

       451
       +
             (* Line break in block context allows simple key *)

     

       452
       +
             t.allow_simple_key <- true;

     

       453
       +
             (* Skip leading blanks *)

     

       454
       +
             while Input.next_is_blank t.input do

     

       455
       +
               Buffer.add_char spaces (Option.get (Input.next t.input))

     

       456
       +
             done;

     

       457
       +
             let col = (Input.position t.input).column in

     

       458
       +
             (* Check indentation - stop if we're at or before the containing block's indent *)

     

       459
       +
             if not in_flow && col <= indent then

     

       460
       +
               () (* Stop - dedented or at parent level *)

     

       461
       +
             else if Input.at_document_boundary t.input then

     

       462
       +
               () (* Stop - document boundary *)

     

       463
       +
             else begin

     

       464
       +
               leading_blanks := true;

     

       465
       +
               scan_lines ()

     

       466
       +
             end

     

       467
       +
           end

     

       468
       +
         in

     

       469
       +
       

     

       470
       +
         scan_lines ();

     

       471
       +
         let value = Buffer.contents buf in

     

       472
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       473
       +
         (value, span)

     

       474
       +
       

     

       475
       +
       (** Scan block scalar (literal | or folded >) *)

     

       476
       +
       let scan_block_scalar t literal =

     

       477
       +
         let start = Input.mark t.input in

     

       478
       +
         ignore (Input.next t.input); (* consume | or > *)

     

       479
       +
       

     

       480
       +
         (* Parse header: optional indentation indicator and chomping *)

     

       481
       +
         let explicit_indent = ref None in

     

       482
       +
         let chomping = ref Chomping.Clip in

     

       483
       +
       

     

       484
       +
         (* First character of header *)

     

       485
       +
         (match Input.peek t.input with

     

       486
       +
          | Some c when Input.is_digit c && c <> '0' ->

     

       487
       +
              explicit_indent := Some (Char.code c - Char.code '0');

     

       488
       +
              ignore (Input.next t.input)

     

       489
       +
          | Some '-' -> chomping := Chomping.Strip; ignore (Input.next t.input)

     

       490
       +
          | Some '+' -> chomping := Chomping.Keep; ignore (Input.next t.input)

     

       491
       +
          | _ -> ());

     

       492
       +
       

     

       493
       +
         (* Second character of header *)

     

       494
       +
         (match Input.peek t.input with

     

       495
       +
          | Some c when Input.is_digit c && c <> '0' && !explicit_indent = None ->

     

       496
       +
              explicit_indent := Some (Char.code c - Char.code '0');

     

       497
       +
              ignore (Input.next t.input)

     

       498
       +
          | Some '-' when !chomping = Chomping.Clip ->

     

       499
       +
              chomping := Chomping.Strip; ignore (Input.next t.input)

     

       500
       +
          | Some '+' when !chomping = Chomping.Clip ->

     

       501
       +
              chomping := Chomping.Keep; ignore (Input.next t.input)

     

       502
       +
          | _ -> ());

     

       503
       +
       

     

       504
       +
         (* Skip to end of line *)

     

       505
       +
         while Input.next_is_blank t.input do

     

       506
       +
           ignore (Input.next t.input)

     

       507
       +
         done;

     

       508
       +
       

     

       509
       +
         (* Optional comment *)

     

       510
       +
         if Input.next_is (( = ) '#') t.input then begin

     

       511
       +
           while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do

     

       512
       +
             ignore (Input.next t.input)

     

       513
       +
           done

     

       514
       +
         end;

     

       515
       +
       

     

       516
       +
         (* Consume line break *)

     

       517
       +
         if Input.next_is_break t.input then

     

       518
       +
           Input.consume_break t.input

     

       519
       +
         else if not (Input.is_eof t.input) then

     

       520
       +
           Error.raise_at (Input.mark t.input)

     

       521
       +
             (Invalid_block_scalar_header "expected newline after header");

     

       522
       +
       

     

       523
       +
         let base_indent = current_indent t in

     

       524
       +
         let content_indent = ref (

     

       525
       +
           match !explicit_indent with

     

       526
       +
           | Some n -> base_indent + n

     

       527
       +
           | None -> 0  (* Will be determined by first non-empty line *)

     

       528
       +
         ) in

     

       529
       +
       

     

       530
       +
         let buf = Buffer.create 256 in

     

       531
       +
         let trailing_breaks = Buffer.create 16 in

     

       532
       +
       

     

       533
       +
         (* Read content *)

     

       534
       +
         let rec read_lines () =

     

       535
       +
           (* Skip empty lines, collecting breaks *)

     

       536
       +
           while Input.next_is_break t.input ||

     

       537
       +
                 (Input.next_is_blank t.input &&

     

       538
       +
                  match Input.peek_nth t.input 1 with

     

       539
       +
                  | Some c when Input.is_break c -> true

     

       540
       +
                  | None -> true

     

       541
       +
                  | _ -> false)

     

       542
       +
           do

     

       543
       +
             if Input.next_is_blank t.input then begin

     

       544
       +
               while Input.next_is_blank t.input do

     

       545
       +
                 ignore (Input.next t.input)

     

       546
       +
               done

     

       547
       +
             end;

     

       548
       +
             if Input.next_is_break t.input then begin

     

       549
       +
               Buffer.add_char trailing_breaks '\n';

     

       550
       +
               Input.consume_break t.input

     

       551
       +
             end

     

       552
       +
           done;

     

       553
       +
       

     

       554
       +
           (* Check if we're at content *)

     

       555
       +
           if Input.is_eof t.input then ()

     

       556
       +
           else if Input.at_document_boundary t.input then ()

     

       557
       +
           else begin

     

       558
       +
             (* Count leading spaces *)

     

       559
       +
             let line_indent = ref 0 in

     

       560
       +
             while Input.next_is (( = ) ' ') t.input do

     

       561
       +
               incr line_indent;

     

       562
       +
               ignore (Input.next t.input)

     

       563
       +
             done;

     

       564
       +
       

     

       565
       +
             (* Determine content indent from first content line *)

     

       566
       +
             if !content_indent = 0 then begin

     

       567
       +
               if !line_indent <= base_indent then begin

     

       568
       +
                 (* No content - restore position conceptually *)

     

       569
       +
                 ()

     

       570
       +
               end else

     

       571
       +
                 content_indent := !line_indent

     

       572
       +
             end;

     

       573
       +
       

     

       574
       +
             if !line_indent < !content_indent then begin

     

       575
       +
               (* Dedented - done with content *)

     

       576
       +
               ()

     

       577
       +
             end else begin

     

       578
       +
               (* Add trailing breaks to buffer *)

     

       579
       +
               if Buffer.length buf > 0 then begin

     

       580
       +
                 if Buffer.length trailing_breaks > 0 then begin

     

       581
       +
                   if literal then

     

       582
       +
                     Buffer.add_buffer buf trailing_breaks

     

       583
       +
                   else begin

     

       584
       +
                     let breaks = Buffer.contents trailing_breaks in

     

       585
       +
                     if String.length breaks = 1 then

     

       586
       +
                       Buffer.add_char buf ' '

     

       587
       +
                     else

     

       588
       +
                       Buffer.add_substring buf breaks 1 (String.length breaks - 1)

     

       589
       +
                   end

     

       590
       +
                 end else if not literal then

     

       591
       +
                   Buffer.add_char buf ' '

     

       592
       +
               end else

     

       593
       +
                 Buffer.add_buffer buf trailing_breaks;

     

       594
       +
               Buffer.clear trailing_breaks;

     

       595
       +
       

     

       596
       +
               (* Add extra indentation for literal *)

     

       597
       +
               if literal then begin

     

       598
       +
                 for _ = !content_indent + 1 to !line_indent do

     

       599
       +
                   Buffer.add_char buf ' '

     

       600
       +
                 done

     

       601
       +
               end;

     

       602
       +
       

     

       603
       +
               (* Read line content *)

     

       604
       +
               while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do

     

       605
       +
                 Buffer.add_char buf (Input.next_exn t.input)

     

       606
       +
               done;

     

       607
       +
       

     

       608
       +
               (* Record trailing break *)

     

       609
       +
               if Input.next_is_break t.input then begin

     

       610
       +
                 Buffer.add_char trailing_breaks '\n';

     

       611
       +
                 Input.consume_break t.input

     

       612
       +
               end;

     

       613
       +
       

     

       614
       +
               read_lines ()

     

       615
       +
             end

     

       616
       +
           end

     

       617
       +
         in

     

       618
       +
       

     

       619
       +
         read_lines ();

     

       620
       +
       

     

       621
       +
         (* Apply chomping *)

     

       622
       +
         let value =

     

       623
       +
           let content = Buffer.contents buf in

     

       624
       +
           match !chomping with

     

       625
       +
           | Chomping.Strip -> content

     

       626
       +
           | Chomping.Clip ->

     

       627
       +
               if String.length content > 0 then content ^ "\n" else content

     

       628
       +
           | Chomping.Keep ->

     

       629
       +
               content ^ Buffer.contents trailing_breaks

     

       630
       +
         in

     

       631
       +
       

     

       632
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       633
       +
         let style = if literal then Scalar_style.Literal else Scalar_style.Folded in

     

       634
       +
         (value, style, span)

     

       635
       +
       

     

       636
       +
       (** Scan directive (after %) *)

     

       637
       +
       let scan_directive t =

     

       638
       +
         let start = Input.mark t.input in

     

       639
       +
         ignore (Input.next t.input); (* consume % *)

     

       640
       +
       

     

       641
       +
         (* Read directive name *)

     

       642
       +
         let name_buf = Buffer.create 16 in

     

       643
       +
         while

     

       644
       +
           match Input.peek t.input with

     

       645
       +
           | Some c when Input.is_alnum c || c = '-' ->

     

       646
       +
               Buffer.add_char name_buf c;

     

       647
       +
               ignore (Input.next t.input);

     

       648
       +
               true

     

       649
       +
           | _ -> false

     

       650
       +
         do () done;

     

       651
       +
         let name = Buffer.contents name_buf in

     

       652
       +
       

     

       653
       +
         (* Skip blanks *)

     

       654
       +
         while Input.next_is_blank t.input do

     

       655
       +
           ignore (Input.next t.input)

     

       656
       +
         done;

     

       657
       +
       

     

       658
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       659
       +
       

     

       660
       +
         match name with

     

       661
       +
         | "YAML" ->

     

       662
       +
             (* Version directive: %YAML 1.2 *)

     

       663
       +
             let major = ref 0 in

     

       664
       +
             let minor = ref 0 in

     

       665
       +
             (* Read major version *)

     

       666
       +
             while Input.next_is_digit t.input do

     

       667
       +
               major := !major * 10 + (Char.code (Input.next_exn t.input) - Char.code '0')

     

       668
       +
             done;

     

       669
       +
             (* Expect . *)

     

       670
       +
             (match Input.peek t.input with

     

       671
       +
              | Some '.' -> ignore (Input.next t.input)

     

       672
       +
              | _ -> Error.raise_at (Input.mark t.input) (Invalid_yaml_version "expected '.'"));

     

       673
       +
             (* Read minor version *)

     

       674
       +
             while Input.next_is_digit t.input do

     

       675
       +
               minor := !minor * 10 + (Char.code (Input.next_exn t.input) - Char.code '0')

     

       676
       +
             done;

     

       677
       +
             let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       678
       +
             Token.Version_directive { major = !major; minor = !minor }, span

     

       679
       +
       

     

       680
       +
         | "TAG" ->

     

       681
       +
             (* Tag directive: %TAG !foo! tag:example.com,2000: *)

     

       682
       +
             let handle = scan_tag_handle t in

     

       683
       +
             (* Skip blanks *)

     

       684
       +
             while Input.next_is_blank t.input do

     

       685
       +
               ignore (Input.next t.input)

     

       686
       +
             done;

     

       687
       +
             (* Read prefix *)

     

       688
       +
             let prefix_buf = Buffer.create 32 in

     

       689
       +
             while

     

       690
       +
               match Input.peek t.input with

     

       691
       +
               | Some c when not (Input.is_whitespace c) ->

     

       692
       +
                   Buffer.add_char prefix_buf c;

     

       693
       +
                   ignore (Input.next t.input);

     

       694
       +
                   true

     

       695
       +
               | _ -> false

     

       696
       +
             do () done;

     

       697
       +
             let prefix = Buffer.contents prefix_buf in

     

       698
       +
             let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       699
       +
             Token.Tag_directive { handle; prefix }, span

     

       700
       +
       

     

       701
       +
         | _ when String.length name > 0 && name.[0] >= 'A' && name.[0] <= 'Z' ->

     

       702
       +
             (* Reserved directive *)

     

       703
       +
             Error.raise_span span (Reserved_directive name)

     

       704
       +
       

     

       705
       +
         | _ ->

     

       706
       +
             (* Unknown directive - skip to end of line *)

     

       707
       +
             while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do

     

       708
       +
               ignore (Input.next t.input)

     

       709
       +
             done;

     

       710
       +
             Error.raise_span span (Invalid_directive name)

     

       711
       +
       

     

       712
       +
       (** Fetch the next token(s) into the queue *)

     

       713
       +
       let rec fetch_next_token t =

     

       714
       +
         skip_to_next_token t;

     

       715
       +
         stale_simple_keys t;

     

       716
       +
         let col = column t in

     

       717
       +
         (* Unroll indents that are deeper than current column.

     

       718
       +
            Note: we use col, not col-1, to allow entries at the same level. *)

     

       719
       +
         unroll_indent t col;

     

       720
       +
       

     

       721
       +
         if Input.is_eof t.input then

     

       722
       +
           fetch_stream_end t

     

       723
       +
         else if Input.at_document_boundary t.input then

     

       724
       +
           fetch_document_indicator t

     

       725
       +
         else begin

     

       726
       +
           match Input.peek t.input with

     

       727
       +
           | None -> fetch_stream_end t

     

       728
       +
           | Some '%' when (Input.position t.input).column = 1 ->

     

       729
       +
               fetch_directive t

     

       730
       +
           | Some '[' -> fetch_flow_collection_start t Token.Flow_sequence_start

     

       731
       +
           | Some '{' -> fetch_flow_collection_start t Token.Flow_mapping_start

     

       732
       +
           | Some ']' -> fetch_flow_collection_end t Token.Flow_sequence_end

     

       733
       +
           | Some '}' -> fetch_flow_collection_end t Token.Flow_mapping_end

     

       734
       +
           | Some ',' -> fetch_flow_entry t

     

       735
       +
           | Some '-' when t.flow_level = 0 && check_block_entry t ->

     

       736
       +
               fetch_block_entry t

     

       737
       +
           | Some '?' when t.flow_level = 0 && check_key t ->

     

       738
       +
               fetch_key t

     

       739
       +
           | Some ':' when check_value t ->

     

       740
       +
               fetch_value t

     

       741
       +
           | Some '*' -> fetch_alias t

     

       742
       +
           | Some '&' -> fetch_anchor t

     

       743
       +
           | Some '!' -> fetch_tag t

     

       744
       +
           | Some '|' when t.flow_level = 0 -> fetch_block_scalar t true

     

       745
       +
           | Some '>' when t.flow_level = 0 -> fetch_block_scalar t false

     

       746
       +
           | Some '\'' -> fetch_single_quoted t

     

       747
       +
           | Some '"' -> fetch_double_quoted t

     

       748
       +
           | Some '-' when can_start_plain t ->

     

       749
       +
               fetch_plain_scalar t

     

       750
       +
           | Some '?' when can_start_plain t ->

     

       751
       +
               fetch_plain_scalar t

     

       752
       +
           | Some ':' when can_start_plain t ->

     

       753
       +
               fetch_plain_scalar t

     

       754
       +
           | Some c when can_start_plain_char c t ->

     

       755
       +
               fetch_plain_scalar t

     

       756
       +
           | Some c ->

     

       757
       +
               Error.raise_at (Input.mark t.input) (Unexpected_character c)

     

       758
       +
         end

     

       759
       +
       

     

       760
       +
       and fetch_stream_end t =

     

       761
       +
         if not t.stream_ended then begin

     

       762
       +
           unroll_indent t (-1);

     

       763
       +
           remove_simple_key t;

     

       764
       +
           t.allow_simple_key <- false;

     

       765
       +
           t.stream_ended <- true;

     

       766
       +
           let span = Span.point (Input.mark t.input) in

     

       767
       +
           emit t span Token.Stream_end

     

       768
       +
         end

     

       769
       +
       

     

       770
       +
       and fetch_document_indicator t =

     

       771
       +
         unroll_indent t (-1);

     

       772
       +
         remove_simple_key t;

     

       773
       +
         t.allow_simple_key <- false;

     

       774
       +
         let start = Input.mark t.input in

     

       775
       +
         let indicator = Input.peek_string t.input 3 in

     

       776
       +
         Input.skip t.input 3;

     

       777
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       778
       +
         let token = if indicator = "---" then Token.Document_start else Token.Document_end in

     

       779
       +
         emit t span token

     

       780
       +
       

     

       781
       +
       and fetch_directive t =

     

       782
       +
         unroll_indent t (-1);

     

       783
       +
         remove_simple_key t;

     

       784
       +
         t.allow_simple_key <- false;

     

       785
       +
         let token, span = scan_directive t in

     

       786
       +
         emit t span token

     

       787
       +
       

     

       788
       +
       and fetch_flow_collection_start t token_type =

     

       789
       +
         save_simple_key t;

     

       790
       +
         t.flow_level <- t.flow_level + 1;

     

       791
       +
         t.allow_simple_key <- true;

     

       792
       +
         t.simple_keys <- None :: t.simple_keys;

     

       793
       +
         let start = Input.mark t.input in

     

       794
       +
         ignore (Input.next t.input);

     

       795
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       796
       +
         emit t span token_type

     

       797
       +
       

     

       798
       +
       and fetch_flow_collection_end t token_type =

     

       799
       +
         remove_simple_key t;

     

       800
       +
         t.flow_level <- t.flow_level - 1;

     

       801
       +
         t.simple_keys <- (match t.simple_keys with _ :: rest -> rest | [] -> []);

     

       802
       +
         t.allow_simple_key <- false;

     

       803
       +
         let start = Input.mark t.input in

     

       804
       +
         ignore (Input.next t.input);

     

       805
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       806
       +
         emit t span token_type

     

       807
       +
       

     

       808
       +
       and fetch_flow_entry t =

     

       809
       +
         remove_simple_key t;

     

       810
       +
         t.allow_simple_key <- true;

     

       811
       +
         let start = Input.mark t.input in

     

       812
       +
         ignore (Input.next t.input);

     

       813
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       814
       +
         emit t span Token.Flow_entry

     

       815
       +
       

     

       816
       +
       and check_block_entry t =

     

       817
       +
         (* - followed by whitespace or EOF *)

     

       818
       +
         match Input.peek_nth t.input 1 with

     

       819
       +
         | None -> true

     

       820
       +
         | Some c -> Input.is_whitespace c

     

       821
       +
       

     

       822
       +
       and fetch_block_entry t =

     

       823
       +
         if t.flow_level = 0 then begin

     

       824
       +
           if not t.allow_simple_key then

     

       825
       +
             Error.raise_at (Input.mark t.input) Expected_block_entry;

     

       826
       +
           let col = column t in

     

       827
       +
           if roll_indent t col ~sequence:true then begin

     

       828
       +
             let span = Span.point (Input.mark t.input) in

     

       829
       +
             emit t span Token.Block_sequence_start

     

       830
       +
           end

     

       831
       +
         end;

     

       832
       +
         remove_simple_key t;

     

       833
       +
         t.allow_simple_key <- true;

     

       834
       +
         let start = Input.mark t.input in

     

       835
       +
         ignore (Input.next t.input);

     

       836
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       837
       +
         emit t span Token.Block_entry

     

       838
       +
       

     

       839
       +
       and check_key t =

     

       840
       +
         (* ? followed by whitespace in block, any in flow *)

     

       841
       +
         if t.flow_level > 0 then true

     

       842
       +
         else match Input.peek_nth t.input 1 with

     

       843
       +
           | None -> true

     

       844
       +
           | Some c -> Input.is_whitespace c

     

       845
       +
       

     

       846
       +
       and fetch_key t =

     

       847
       +
         if t.flow_level = 0 then begin

     

       848
       +
           if not t.allow_simple_key then

     

       849
       +
             Error.raise_at (Input.mark t.input) Expected_key;

     

       850
       +
           let col = column t in

     

       851
       +
           if roll_indent t col ~sequence:false then begin

     

       852
       +
             let span = Span.point (Input.mark t.input) in

     

       853
       +
             emit t span Token.Block_mapping_start

     

       854
       +
           end

     

       855
       +
         end;

     

       856
       +
         remove_simple_key t;

     

       857
       +
         t.allow_simple_key <- t.flow_level = 0;

     

       858
       +
         let start = Input.mark t.input in

     

       859
       +
         ignore (Input.next t.input);

     

       860
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       861
       +
         emit t span Token.Key

     

       862
       +
       

     

       863
       +
       and check_value t =

     

       864
       +
         (* : followed by whitespace in block, or flow indicator in flow *)

     

       865
       +
         if t.flow_level > 0 then true

     

       866
       +
         else match Input.peek_nth t.input 1 with

     

       867
       +
           | None -> true

     

       868
       +
           | Some c -> Input.is_whitespace c

     

       869
       +
       

     

       870
       +
       and fetch_value t =

     

       871
       +
         (* Check for simple key *)

     

       872
       +
         (match t.simple_keys with

     

       873
       +
          | Some sk :: _ when sk.sk_possible ->

     

       874
       +
              (* Insert KEY token before the simple key value *)

     

       875
       +
              let key_span = Span.point sk.sk_position in

     

       876
       +
              let key_token = { Token.token = Token.Key; span = key_span } in

     

       877
       +
              (* We need to insert at the right position *)

     

       878
       +
              let tokens = Queue.to_seq t.tokens |> Array.of_seq in

     

       879
       +
              Queue.clear t.tokens;

     

       880
       +
              let insert_pos = sk.sk_token_number - t.tokens_taken in

     

       881
       +
              Array.iteri (fun i tok ->

     

       882
       +
                if i = insert_pos then Queue.add key_token t.tokens;

     

       883
       +
                Queue.add tok t.tokens

     

       884
       +
              ) tokens;

     

       885
       +
              if insert_pos >= Array.length tokens then

     

       886
       +
                Queue.add key_token t.tokens;

     

       887
       +
              t.token_number <- t.token_number + 1;

     

       888
       +
              (* Roll indent for implicit block mapping *)

     

       889
       +
              if t.flow_level = 0 then begin

     

       890
       +
                let col = sk.sk_position.column in

     

       891
       +
                if roll_indent t col ~sequence:false then begin

     

       892
       +
                  let span = Span.point sk.sk_position in

     

       893
       +
                  (* Insert block mapping start before key *)

     

       894
       +
                  let bm_token = { Token.token = Token.Block_mapping_start; span } in

     

       895
       +
                  let tokens = Queue.to_seq t.tokens |> Array.of_seq in

     

       896
       +
                  Queue.clear t.tokens;

     

       897
       +
                  Array.iteri (fun i tok ->

     

       898
       +
                    if i = insert_pos then Queue.add bm_token t.tokens;

     

       899
       +
                    Queue.add tok t.tokens

     

       900
       +
                  ) tokens;

     

       901
       +
                  if insert_pos >= Array.length tokens then

     

       902
       +
                    Queue.add bm_token t.tokens;

     

       903
       +
                  t.token_number <- t.token_number + 1

     

       904
       +
                end

     

       905
       +
              end;

     

       906
       +
              t.simple_keys <- None :: (List.tl t.simple_keys)

     

       907
       +
          | _ ->

     

       908
       +
              (* No simple key - this is a complex value *)

     

       909
       +
              if t.flow_level = 0 then begin

     

       910
       +
                if not t.allow_simple_key then

     

       911
       +
                  Error.raise_at (Input.mark t.input) Expected_key;

     

       912
       +
                let col = column t in

     

       913
       +
                if roll_indent t col ~sequence:false then begin

     

       914
       +
                  let span = Span.point (Input.mark t.input) in

     

       915
       +
                  emit t span Token.Block_mapping_start

     

       916
       +
                end

     

       917
       +
              end);

     

       918
       +
         remove_simple_key t;

     

       919
       +
         t.allow_simple_key <- t.flow_level = 0;

     

       920
       +
         let start = Input.mark t.input in

     

       921
       +
         ignore (Input.next t.input);

     

       922
       +
         let span = Span.make ~start ~stop:(Input.mark t.input) in

     

       923
       +
         emit t span Token.Value

     

       924
       +
       

     

       925
       +
       and fetch_alias t =

     

       926
       +
         save_simple_key t;

     

       927
       +
         t.allow_simple_key <- false;

     

       928
       +
         let start = Input.mark t.input in

     

       929
       +
         ignore (Input.next t.input); (* consume * *)

     

       930
       +
         let name, span = scan_anchor_alias t in

     

       931
       +
         let span = Span.make ~start ~stop:span.stop in

     

       932
       +
         emit t span (Token.Alias name)

     

       933
       +
       

     

       934
       +
       and fetch_anchor t =

     

       935
       +
         save_simple_key t;

     

       936
       +
         t.allow_simple_key <- false;

     

       937
       +
         let start = Input.mark t.input in

     

       938
       +
         ignore (Input.next t.input); (* consume & *)

     

       939
       +
         let name, span = scan_anchor_alias t in

     

       940
       +
         let span = Span.make ~start ~stop:span.stop in

     

       941
       +
         emit t span (Token.Anchor name)

     

       942
       +
       

     

       943
       +
       and fetch_tag t =

     

       944
       +
         save_simple_key t;

     

       945
       +
         t.allow_simple_key <- false;

     

       946
       +
         let handle, suffix, span = scan_tag t in

     

       947
       +
         emit t span (Token.Tag { handle; suffix })

     

       948
       +
       

     

       949
       +
       and fetch_block_scalar t literal =

     

       950
       +
         remove_simple_key t;

     

       951
       +
         t.allow_simple_key <- true;

     

       952
       +
         let value, style, span = scan_block_scalar t literal in

     

       953
       +
         emit t span (Token.Scalar { style; value })

     

       954
       +
       

     

       955
       +
       and fetch_single_quoted t =

     

       956
       +
         save_simple_key t;

     

       957
       +
         t.allow_simple_key <- false;

     

       958
       +
         let value, span = scan_single_quoted t in

     

       959
       +
         emit t span (Token.Scalar { style = Scalar_style.Single_quoted; value })

     

       960
       +
       

     

       961
       +
       and fetch_double_quoted t =

     

       962
       +
         save_simple_key t;

     

       963
       +
         t.allow_simple_key <- false;

     

       964
       +
         let value, span = scan_double_quoted t in

     

       965
       +
         emit t span (Token.Scalar { style = Scalar_style.Double_quoted; value })

     

       966
       +
       

     

       967
       +
       and can_start_plain t =

     

       968
       +
         (* Check if - ? : can start a plain scalar *)

     

       969
       +
         match Input.peek_nth t.input 1 with

     

       970
       +
         | None -> false

     

       971
       +
         | Some c ->

     

       972
       +
             not (Input.is_whitespace c) &&

     

       973
       +
             (t.flow_level = 0 || not (Input.is_flow_indicator c))

     

       974
       +
       

     

       975
       +
       and can_start_plain_char c _t =

     

       976
       +
         (* Characters that can start a plain scalar *)

     

       977
       +
         if Input.is_whitespace c then false

     

       978
       +
         else if Input.is_indicator c then false

     

       979
       +
         else true

     

       980
       +
       

     

       981
       +
       and fetch_plain_scalar t =

     

       982
       +
         save_simple_key t;

     

       983
       +
         t.allow_simple_key <- false;

     

       984
       +
         let value, span = scan_plain_scalar t in

     

       985
       +
         emit t span (Token.Scalar { style = Scalar_style.Plain; value })

     

       986
       +
       

     

       987
       +
       (** Check if we need more tokens to resolve simple keys *)

     

       988
       +
       let need_more_tokens t =

     

       989
       +
         if t.stream_ended then false

     

       990
       +
         else if Queue.is_empty t.tokens then true

     

       991
       +
         else

     

       992
       +
           (* Check if any simple key could affect the first queued token *)

     

       993
       +
           List.exists (function

     

       994
       +
             | Some sk when sk.sk_possible ->

     

       995
       +
                 sk.sk_token_number >= t.tokens_taken

     

       996
       +
             | _ -> false

     

       997
       +
           ) t.simple_keys

     

       998
       +
       

     

       999
       +
       (** Ensure we have enough tokens to return one safely *)

     

       1000
       +
       let ensure_tokens t =

     

       1001
       +
         if not t.stream_started then begin

     

       1002
       +
           t.stream_started <- true;

     

       1003
       +
           let span = Span.point (Input.position t.input) in

     

       1004
       +
           let encoding, _ = Encoding.detect t.input.source in

     

       1005
       +
           emit t span (Token.Stream_start encoding)

     

       1006
       +
         end;

     

       1007
       +
         while need_more_tokens t do

     

       1008
       +
           fetch_next_token t

     

       1009
       +
         done

     

       1010
       +
       

     

       1011
       +
       (** Get next token *)

     

       1012
       +
       let next t =

     

       1013
       +
         ensure_tokens t;

     

       1014
       +
         if Queue.is_empty t.tokens then

     

       1015
       +
           None

     

       1016
       +
         else begin

     

       1017
       +
           t.tokens_taken <- t.tokens_taken + 1;

     

       1018
       +
           Some (Queue.pop t.tokens)

     

       1019
       +
         end

     

       1020
       +
       

     

       1021
       +
       (** Peek at next token *)

     

       1022
       +
       let peek t =

     

       1023
       +
         ensure_tokens t;

     

       1024
       +
         Queue.peek_opt t.tokens

     

       1025
       +
       

     

       1026
       +
       (** Iterate over all tokens *)

     

       1027
       +
       let iter f t =

     

       1028
       +
         let rec loop () =

     

       1029
       +
           match next t with

     

       1030
       +
           | None -> ()

     

       1031
       +
           | Some tok -> f tok; loop ()

     

       1032
       +
         in

     

       1033
       +
         loop ()

     

       1034
       +
       

     

       1035
       +
       (** Fold over all tokens *)

     

       1036
       +
       let fold f init t =

     

       1037
       +
         let rec loop acc =

     

       1038
       +
           match next t with

     

       1039
       +
           | None -> acc

     

       1040
       +
           | Some tok -> loop (f acc tok)

     

       1041
       +
         in

     

       1042
       +
         loop init

     

       1043
       +
       

     

       1044
       +
       (** Convert to list *)

     

       1045
       +
       let to_list t =

     

       1046
       +
         fold (fun acc tok -> tok :: acc) [] t |> List.rev

+72

yaml/ocaml-yamle/lib/sequence.ml

···

       1
       +
       (** YAML sequence (array) values with metadata *)

     

       2
       +
       

     

       3
       +
       type 'a t = {

     

       4
       +
         anchor : string option;

     

       5
       +
         tag : string option;

     

       6
       +
         implicit : bool;

     

       7
       +
         style : Layout_style.t;

     

       8
       +
         members : 'a list;

     

       9
       +
       }

     

       10
       +
       

     

       11
       +
       let make

     

       12
       +
           ?(anchor : string option)

     

       13
       +
           ?(tag : string option)

     

       14
       +
           ?(implicit = true)

     

       15
       +
           ?(style = Layout_style.Any)

     

       16
       +
           members =

     

       17
       +
         { anchor; tag; implicit; style; members }

     

       18
       +
       

     

       19
       +
       let members t = t.members

     

       20
       +
       let anchor t = t.anchor

     

       21
       +
       let tag t = t.tag

     

       22
       +
       let implicit t = t.implicit

     

       23
       +
       let style t = t.style

     

       24
       +
       

     

       25
       +
       let with_anchor anchor t = { t with anchor = Some anchor }

     

       26
       +
       let with_tag tag t = { t with tag = Some tag }

     

       27
       +
       let with_style style t = { t with style }

     

       28
       +
       

     

       29
       +
       let map f t = { t with members = List.map f t.members }

     

       30
       +
       

     

       31
       +
       let length t = List.length t.members

     

       32
       +
       

     

       33
       +
       let is_empty t = t.members = []

     

       34
       +
       

     

       35
       +
       let nth t n = List.nth t.members n

     

       36
       +
       

     

       37
       +
       let nth_opt t n = List.nth_opt t.members n

     

       38
       +
       

     

       39
       +
       let iter f t = List.iter f t.members

     

       40
       +
       

     

       41
       +
       let fold f init t = List.fold_left f init t.members

     

       42
       +
       

     

       43
       +
       let pp pp_elem fmt t =

     

       44
       +
         Format.fprintf fmt "@[<hv 2>sequence(@,";

     

       45
       +
         (match t.anchor with

     

       46
       +
          | Some a -> Format.fprintf fmt "anchor=%s,@ " a

     

       47
       +
          | None -> ());

     

       48
       +
         (match t.tag with

     

       49
       +
          | Some tag -> Format.fprintf fmt "tag=%s,@ " tag

     

       50
       +
          | None -> ());

     

       51
       +
         Format.fprintf fmt "style=%a,@ " Layout_style.pp t.style;

     

       52
       +
         Format.fprintf fmt "members=[@,%a@]@,)"

     

       53
       +
           (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") pp_elem)

     

       54
       +
           t.members

     

       55
       +
       

     

       56
       +
       let equal eq a b =

     

       57
       +
         Option.equal String.equal a.anchor b.anchor &&

     

       58
       +
         Option.equal String.equal a.tag b.tag &&

     

       59
       +
         a.implicit = b.implicit &&

     

       60
       +
         Layout_style.equal a.style b.style &&

     

       61
       +
         List.equal eq a.members b.members

     

       62
       +
       

     

       63
       +
       let compare cmp a b =

     

       64
       +
         let c = Option.compare String.compare a.anchor b.anchor in

     

       65
       +
         if c <> 0 then c else

     

       66
       +
         let c = Option.compare String.compare a.tag b.tag in

     

       67
       +
         if c <> 0 then c else

     

       68
       +
         let c = Bool.compare a.implicit b.implicit in

     

       69
       +
         if c <> 0 then c else

     

       70
       +
         let c = Layout_style.compare a.style b.style in

     

       71
       +
         if c <> 0 then c else

     

       72
       +
         List.compare cmp a.members b.members

+35

yaml/ocaml-yamle/lib/span.ml

···

       1
       +
       (** Source spans representing ranges in input *)

     

       2
       +
       

     

       3
       +
       type t = {

     

       4
       +
         start : Position.t;

     

       5
       +
         stop : Position.t;

     

       6
       +
       }

     

       7
       +
       

     

       8
       +
       let make ~start ~stop = { start; stop }

     

       9
       +
       

     

       10
       +
       let point pos = { start = pos; stop = pos }

     

       11
       +
       

     

       12
       +
       let merge a b =

     

       13
       +
         let start = if Position.compare a.start b.start <= 0 then a.start else b.start in

     

       14
       +
         let stop = if Position.compare a.stop b.stop >= 0 then a.stop else b.stop in

     

       15
       +
         { start; stop }

     

       16
       +
       

     

       17
       +
       let extend span pos =

     

       18
       +
         { span with stop = pos }

     

       19
       +
       

     

       20
       +
       let pp fmt t =

     

       21
       +
         if t.start.line = t.stop.line then

     

       22
       +
           Format.fprintf fmt "line %d, columns %d-%d"

     

       23
       +
             t.start.line t.start.column t.stop.column

     

       24
       +
         else

     

       25
       +
           Format.fprintf fmt "lines %d-%d" t.start.line t.stop.line

     

       26
       +
       

     

       27
       +
       let to_string t =

     

       28
       +
         Format.asprintf "%a" pp t

     

       29
       +
       

     

       30
       +
       let compare a b =

     

       31
       +
         let c = Position.compare a.start b.start in

     

       32
       +
         if c <> 0 then c else Position.compare a.stop b.stop

     

       33
       +
       

     

       34
       +
       let equal a b =

     

       35
       +
         Position.equal a.start b.start && Position.equal a.stop b.stop

+70

yaml/ocaml-yamle/lib/tag.ml

···

       1
       +
       (** YAML tags for type information *)

     

       2
       +
       

     

       3
       +
       type t = {

     

       4
       +
         handle : string;  (** e.g., "!" or "!!" or "!foo!" *)

     

       5
       +
         suffix : string;  (** e.g., "str", "int", "custom/type" *)

     

       6
       +
       }

     

       7
       +
       

     

       8
       +
       let make ~handle ~suffix = { handle; suffix }

     

       9
       +
       

     

       10
       +
       let of_string s =

     

       11
       +
         if String.length s = 0 then None

     

       12
       +
         else if s.[0] <> '!' then None

     

       13
       +
         else

     

       14
       +
           (* Find the suffix after the handle *)

     

       15
       +
           let len = String.length s in

     

       16
       +
           if len = 1 then Some { handle = "!"; suffix = "" }

     

       17
       +
           else if s.[1] = '!' then

     

       18
       +
             (* !! handle *)

     

       19
       +
             Some { handle = "!!"; suffix = String.sub s 2 (len - 2) }

     

       20
       +
           else if s.[1] = '<' then

     

       21
       +
             (* Verbatim tag !<...> *)

     

       22
       +
             if len > 2 && s.[len - 1] = '>' then

     

       23
       +
               Some { handle = "!"; suffix = String.sub s 2 (len - 3) }

     

       24
       +
             else

     

       25
       +
               None

     

       26
       +
           else

     

       27
       +
             (* Primary handle or local tag *)

     

       28
       +
             Some { handle = "!"; suffix = String.sub s 1 (len - 1) }

     

       29
       +
       

     

       30
       +
       let to_string t =

     

       31
       +
         if t.handle = "!" && t.suffix = "" then "!"

     

       32
       +
         else t.handle ^ t.suffix

     

       33
       +
       

     

       34
       +
       let to_uri t =

     

       35
       +
         match t.handle with

     

       36
       +
         | "!!" -> "tag:yaml.org,2002:" ^ t.suffix

     

       37
       +
         | "!" -> "!" ^ t.suffix

     

       38
       +
         | h -> h ^ t.suffix

     

       39
       +
       

     

       40
       +
       let pp fmt t =

     

       41
       +
         Format.pp_print_string fmt (to_string t)

     

       42
       +
       

     

       43
       +
       let equal a b =

     

       44
       +
         String.equal a.handle b.handle && String.equal a.suffix b.suffix

     

       45
       +
       

     

       46
       +
       let compare a b =

     

       47
       +
         let c = String.compare a.handle b.handle in

     

       48
       +
         if c <> 0 then c else String.compare a.suffix b.suffix

     

       49
       +
       

     

       50
       +
       (** Standard tags *)

     

       51
       +
       

     

       52
       +
       let null = { handle = "!!"; suffix = "null" }

     

       53
       +
       let bool = { handle = "!!"; suffix = "bool" }

     

       54
       +
       let int = { handle = "!!"; suffix = "int" }

     

       55
       +
       let float = { handle = "!!"; suffix = "float" }

     

       56
       +
       let str = { handle = "!!"; suffix = "str" }

     

       57
       +
       let seq = { handle = "!!"; suffix = "seq" }

     

       58
       +
       let map = { handle = "!!"; suffix = "map" }

     

       59
       +
       let binary = { handle = "!!"; suffix = "binary" }

     

       60
       +
       let timestamp = { handle = "!!"; suffix = "timestamp" }

     

       61
       +
       

     

       62
       +
       (** Check if tag matches a standard type *)

     

       63
       +
       

     

       64
       +
       let is_null t = equal t null || (t.handle = "!" && t.suffix = "")

     

       65
       +
       let is_bool t = equal t bool

     

       66
       +
       let is_int t = equal t int

     

       67
       +
       let is_float t = equal t float

     

       68
       +
       let is_str t = equal t str

     

       69
       +
       let is_seq t = equal t seq

     

       70
       +
       let is_map t = equal t map

+78

yaml/ocaml-yamle/lib/token.ml

···

       1
       +
       (** YAML token types produced by the scanner *)

     

       2
       +
       

     

       3
       +
       type t =

     

       4
       +
         | Stream_start of Encoding.t

     

       5
       +
         | Stream_end

     

       6
       +
         | Version_directive of { major : int; minor : int }

     

       7
       +
         | Tag_directive of { handle : string; prefix : string }

     

       8
       +
         | Document_start    (** --- *)

     

       9
       +
         | Document_end      (** ... *)

     

       10
       +
         | Block_sequence_start

     

       11
       +
         | Block_mapping_start

     

       12
       +
         | Block_entry       (** - *)

     

       13
       +
         | Block_end         (** implicit, from dedent *)

     

       14
       +
         | Flow_sequence_start  (** [ *)

     

       15
       +
         | Flow_sequence_end    (** ] *)

     

       16
       +
         | Flow_mapping_start   (** { *)

     

       17
       +
         | Flow_mapping_end     (** } *)

     

       18
       +
         | Flow_entry        (** , *)

     

       19
       +
         | Key               (** ? or implicit key *)

     

       20
       +
         | Value             (** : *)

     

       21
       +
         | Anchor of string  (** &name *)

     

       22
       +
         | Alias of string   (** *name *)

     

       23
       +
         | Tag of { handle : string; suffix : string }

     

       24
       +
         | Scalar of { style : Scalar_style.t; value : string }

     

       25
       +
       

     

       26
       +
       type spanned = {

     

       27
       +
         token : t;

     

       28
       +
         span : Span.t;

     

       29
       +
       }

     

       30
       +
       

     

       31
       +
       let pp_token fmt = function

     

       32
       +
         | Stream_start enc ->

     

       33
       +
             Format.fprintf fmt "STREAM-START(%a)" Encoding.pp enc

     

       34
       +
         | Stream_end ->

     

       35
       +
             Format.fprintf fmt "STREAM-END"

     

       36
       +
         | Version_directive { major; minor } ->

     

       37
       +
             Format.fprintf fmt "VERSION-DIRECTIVE(%d.%d)" major minor

     

       38
       +
         | Tag_directive { handle; prefix } ->

     

       39
       +
             Format.fprintf fmt "TAG-DIRECTIVE(%s, %s)" handle prefix

     

       40
       +
         | Document_start ->

     

       41
       +
             Format.fprintf fmt "DOCUMENT-START"

     

       42
       +
         | Document_end ->

     

       43
       +
             Format.fprintf fmt "DOCUMENT-END"

     

       44
       +
         | Block_sequence_start ->

     

       45
       +
             Format.fprintf fmt "BLOCK-SEQUENCE-START"

     

       46
       +
         | Block_mapping_start ->

     

       47
       +
             Format.fprintf fmt "BLOCK-MAPPING-START"

     

       48
       +
         | Block_entry ->

     

       49
       +
             Format.fprintf fmt "BLOCK-ENTRY"

     

       50
       +
         | Block_end ->

     

       51
       +
             Format.fprintf fmt "BLOCK-END"

     

       52
       +
         | Flow_sequence_start ->

     

       53
       +
             Format.fprintf fmt "FLOW-SEQUENCE-START"

     

       54
       +
         | Flow_sequence_end ->

     

       55
       +
             Format.fprintf fmt "FLOW-SEQUENCE-END"

     

       56
       +
         | Flow_mapping_start ->

     

       57
       +
             Format.fprintf fmt "FLOW-MAPPING-START"

     

       58
       +
         | Flow_mapping_end ->

     

       59
       +
             Format.fprintf fmt "FLOW-MAPPING-END"

     

       60
       +
         | Flow_entry ->

     

       61
       +
             Format.fprintf fmt "FLOW-ENTRY"

     

       62
       +
         | Key ->

     

       63
       +
             Format.fprintf fmt "KEY"

     

       64
       +
         | Value ->

     

       65
       +
             Format.fprintf fmt "VALUE"

     

       66
       +
         | Anchor name ->

     

       67
       +
             Format.fprintf fmt "ANCHOR(%s)" name

     

       68
       +
         | Alias name ->

     

       69
       +
             Format.fprintf fmt "ALIAS(%s)" name

     

       70
       +
         | Tag { handle; suffix } ->

     

       71
       +
             Format.fprintf fmt "TAG(%s, %s)" handle suffix

     

       72
       +
         | Scalar { style; value } ->

     

       73
       +
             Format.fprintf fmt "SCALAR(%a, %S)" Scalar_style.pp style value

     

       74
       +
       

     

       75
       +
       let pp fmt t = pp_token fmt t

     

       76
       +
       

     

       77
       +
       let pp_spanned fmt { token; span } =

     

       78
       +
         Format.fprintf fmt "%a at %a" pp_token token Span.pp span

+182

yaml/ocaml-yamle/lib/value.ml

···

       1
       +
       (** JSON-compatible YAML value representation *)

     

       2
       +
       

     

       3
       +
       type t = [

     

       4
       +
         | `Null

     

       5
       +
         | `Bool of bool

     

       6
       +
         | `Float of float

     

       7
       +
         | `String of string

     

       8
       +
         | `A of t list

     

       9
       +
         | `O of (string * t) list

     

       10
       +
       ]

     

       11
       +
       

     

       12
       +
       (** Constructors *)

     

       13
       +
       

     

       14
       +
       let null : t = `Null

     

       15
       +
       let bool b : t = `Bool b

     

       16
       +
       let int n : t = `Float (Float.of_int n)

     

       17
       +
       let float f : t = `Float f

     

       18
       +
       let string s : t = `String s

     

       19
       +
       

     

       20
       +
       let list f xs : t = `A (List.map f xs)

     

       21
       +
       let obj pairs : t = `O pairs

     

       22
       +
       

     

       23
       +
       (** Type name for error messages *)

     

       24
       +
       let type_name : t -> string = function

     

       25
       +
         | `Null -> "null"

     

       26
       +
         | `Bool _ -> "bool"

     

       27
       +
         | `Float _ -> "float"

     

       28
       +
         | `String _ -> "string"

     

       29
       +
         | `A _ -> "array"

     

       30
       +
         | `O _ -> "object"

     

       31
       +
       

     

       32
       +
       (** Safe accessors (return option) *)

     

       33
       +
       

     

       34
       +
       let as_null = function `Null -> Some () | _ -> None

     

       35
       +
       let as_bool = function `Bool b -> Some b | _ -> None

     

       36
       +
       let as_float = function `Float f -> Some f | _ -> None

     

       37
       +
       let as_string = function `String s -> Some s | _ -> None

     

       38
       +
       let as_list = function `A l -> Some l | _ -> None

     

       39
       +
       let as_assoc = function `O o -> Some o | _ -> None

     

       40
       +
       

     

       41
       +
       let as_int = function

     

       42
       +
         | `Float f ->

     

       43
       +
             let i = Float.to_int f in

     

       44
       +
             if Float.equal (Float.of_int i) f then Some i else None

     

       45
       +
         | _ -> None

     

       46
       +
       

     

       47
       +
       (** Unsafe accessors (raise on type mismatch) *)

     

       48
       +
       

     

       49
       +
       let to_null v =

     

       50
       +
         match as_null v with

     

       51
       +
         | Some () -> ()

     

       52
       +
         | None -> Error.raise (Type_mismatch ("null", type_name v))

     

       53
       +
       

     

       54
       +
       let to_bool v =

     

       55
       +
         match as_bool v with

     

       56
       +
         | Some b -> b

     

       57
       +
         | None -> Error.raise (Type_mismatch ("bool", type_name v))

     

       58
       +
       

     

       59
       +
       let to_float v =

     

       60
       +
         match as_float v with

     

       61
       +
         | Some f -> f

     

       62
       +
         | None -> Error.raise (Type_mismatch ("float", type_name v))

     

       63
       +
       

     

       64
       +
       let to_string v =

     

       65
       +
         match as_string v with

     

       66
       +
         | Some s -> s

     

       67
       +
         | None -> Error.raise (Type_mismatch ("string", type_name v))

     

       68
       +
       

     

       69
       +
       let to_list v =

     

       70
       +
         match as_list v with

     

       71
       +
         | Some l -> l

     

       72
       +
         | None -> Error.raise (Type_mismatch ("array", type_name v))

     

       73
       +
       

     

       74
       +
       let to_assoc v =

     

       75
       +
         match as_assoc v with

     

       76
       +
         | Some o -> o

     

       77
       +
         | None -> Error.raise (Type_mismatch ("object", type_name v))

     

       78
       +
       

     

       79
       +
       let to_int v =

     

       80
       +
         match as_int v with

     

       81
       +
         | Some i -> i

     

       82
       +
         | None -> Error.raise (Type_mismatch ("int", type_name v))

     

       83
       +
       

     

       84
       +
       (** Object access *)

     

       85
       +
       

     

       86
       +
       let mem key = function

     

       87
       +
         | `O pairs -> List.exists (fun (k, _) -> k = key) pairs

     

       88
       +
         | _ -> false

     

       89
       +
       

     

       90
       +
       let find key = function

     

       91
       +
         | `O pairs -> List.assoc_opt key pairs

     

       92
       +
         | _ -> None

     

       93
       +
       

     

       94
       +
       let get key v =

     

       95
       +
         match find key v with

     

       96
       +
         | Some v -> v

     

       97
       +
         | None -> Error.raise (Key_not_found key)

     

       98
       +
       

     

       99
       +
       let keys = function

     

       100
       +
         | `O pairs -> List.map fst pairs

     

       101
       +
         | v -> Error.raise (Type_mismatch ("object", type_name v))

     

       102
       +
       

     

       103
       +
       let values = function

     

       104
       +
         | `O pairs -> List.map snd pairs

     

       105
       +
         | v -> Error.raise (Type_mismatch ("object", type_name v))

     

       106
       +
       

     

       107
       +
       (** Combinators *)

     

       108
       +
       

     

       109
       +
       let combine v1 v2 =

     

       110
       +
         match v1, v2 with

     

       111
       +
         | `O o1, `O o2 -> `O (o1 @ o2)

     

       112
       +
         | v1, _ -> Error.raise (Type_mismatch ("object", type_name v1))

     

       113
       +
       

     

       114
       +
       let map f = function

     

       115
       +
         | `A l -> `A (List.map f l)

     

       116
       +
         | v -> Error.raise (Type_mismatch ("array", type_name v))

     

       117
       +
       

     

       118
       +
       let filter pred = function

     

       119
       +
         | `A l -> `A (List.filter pred l)

     

       120
       +
         | v -> Error.raise (Type_mismatch ("array", type_name v))

     

       121
       +
       

     

       122
       +
       (** Pretty printing *)

     

       123
       +
       

     

       124
       +
       let rec pp fmt (v : t) =

     

       125
       +
         match v with

     

       126
       +
         | `Null -> Format.pp_print_string fmt "null"

     

       127
       +
         | `Bool b -> Format.pp_print_bool fmt b

     

       128
       +
         | `Float f ->

     

       129
       +
             if Float.is_integer f && Float.abs f < 1e15 then

     

       130
       +
               Format.fprintf fmt "%.0f" f

     

       131
       +
             else

     

       132
       +
               Format.fprintf fmt "%g" f

     

       133
       +
         | `String s -> Format.fprintf fmt "%S" s

     

       134
       +
         | `A [] -> Format.pp_print_string fmt "[]"

     

       135
       +
         | `A items ->

     

       136
       +
             Format.fprintf fmt "@[<hv 2>[@,%a@]@,]"

     

       137
       +
               (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") pp)

     

       138
       +
               items

     

       139
       +
         | `O [] -> Format.pp_print_string fmt "{}"

     

       140
       +
         | `O pairs ->

     

       141
       +
             Format.fprintf fmt "@[<hv 2>{@,%a@]@,}"

     

       142
       +
               (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")

     

       143
       +
                  (fun fmt (k, v) -> Format.fprintf fmt "@[<hv 2>%S:@ %a@]" k pp v))

     

       144
       +
               pairs

     

       145
       +
       

     

       146
       +
       (** Equality and comparison *)

     

       147
       +
       

     

       148
       +
       let rec equal (a : t) (b : t) =

     

       149
       +
         match a, b with

     

       150
       +
         | `Null, `Null -> true

     

       151
       +
         | `Bool a, `Bool b -> a = b

     

       152
       +
         | `Float a, `Float b -> Float.equal a b

     

       153
       +
         | `String a, `String b -> String.equal a b

     

       154
       +
         | `A a, `A b -> List.equal equal a b

     

       155
       +
         | `O a, `O b ->

     

       156
       +
             List.length a = List.length b &&

     

       157
       +
             List.for_all2 (fun (k1, v1) (k2, v2) -> k1 = k2 && equal v1 v2) a b

     

       158
       +
         | _ -> false

     

       159
       +
       

     

       160
       +
       let rec compare (a : t) (b : t) =

     

       161
       +
         match a, b with

     

       162
       +
         | `Null, `Null -> 0

     

       163
       +
         | `Null, _ -> -1

     

       164
       +
         | _, `Null -> 1

     

       165
       +
         | `Bool a, `Bool b -> Bool.compare a b

     

       166
       +
         | `Bool _, _ -> -1

     

       167
       +
         | _, `Bool _ -> 1

     

       168
       +
         | `Float a, `Float b -> Float.compare a b

     

       169
       +
         | `Float _, _ -> -1

     

       170
       +
         | _, `Float _ -> 1

     

       171
       +
         | `String a, `String b -> String.compare a b

     

       172
       +
         | `String _, _ -> -1

     

       173
       +
         | _, `String _ -> 1

     

       174
       +
         | `A a, `A b -> List.compare compare a b

     

       175
       +
         | `A _, _ -> -1

     

       176
       +
         | _, `A _ -> 1

     

       177
       +
         | `O a, `O b ->

     

       178
       +
             let cmp_pair (k1, v1) (k2, v2) =

     

       179
       +
               let c = String.compare k1 k2 in

     

       180
       +
               if c <> 0 then c else compare v1 v2

     

       181
       +
             in

     

       182
       +
             List.compare cmp_pair a b

+224

yaml/ocaml-yamle/lib/yaml.ml

···

       1
       +
       (** Full YAML representation with anchors, tags, and aliases *)

     

       2
       +
       

     

       3
       +
       type t = [

     

       4
       +
         | `Scalar of Scalar.t

     

       5
       +
         | `Alias of string

     

       6
       +
         | `A of t Sequence.t

     

       7
       +
         | `O of (t, t) Mapping.t

     

       8
       +
       ]

     

       9
       +
       

     

       10
       +
       (** Pretty printing *)

     

       11
       +
       

     

       12
       +
       let rec pp fmt (v : t) =

     

       13
       +
         match v with

     

       14
       +
         | `Scalar s -> Scalar.pp fmt s

     

       15
       +
         | `Alias name -> Format.fprintf fmt "*%s" name

     

       16
       +
         | `A seq -> Sequence.pp pp fmt seq

     

       17
       +
         | `O map -> Mapping.pp pp pp fmt map

     

       18
       +
       

     

       19
       +
       (** Equality *)

     

       20
       +
       

     

       21
       +
       let rec equal (a : t) (b : t) =

     

       22
       +
         match a, b with

     

       23
       +
         | `Scalar a, `Scalar b -> Scalar.equal a b

     

       24
       +
         | `Alias a, `Alias b -> String.equal a b

     

       25
       +
         | `A a, `A b -> Sequence.equal equal a b

     

       26
       +
         | `O a, `O b -> Mapping.equal equal equal a b

     

       27
       +
         | _ -> false

     

       28
       +
       

     

       29
       +
       (** Construct from JSON-compatible Value *)

     

       30
       +
       

     

       31
       +
       let rec of_value (v : Value.t) : t =

     

       32
       +
         match v with

     

       33
       +
         | `Null -> `Scalar (Scalar.make "null")

     

       34
       +
         | `Bool true -> `Scalar (Scalar.make "true")

     

       35
       +
         | `Bool false -> `Scalar (Scalar.make "false")

     

       36
       +
         | `Float f ->

     

       37
       +
             let s =

     

       38
       +
               if Float.is_integer f && Float.abs f < 1e15 then

     

       39
       +
                 Printf.sprintf "%.0f" f

     

       40
       +
               else

     

       41
       +
                 Printf.sprintf "%g" f

     

       42
       +
             in

     

       43
       +
             `Scalar (Scalar.make s)

     

       44
       +
         | `String s ->

     

       45
       +
             `Scalar (Scalar.make s ~style:Scalar_style.Double_quoted)

     

       46
       +
         | `A items ->

     

       47
       +
             `A (Sequence.make (List.map of_value items))

     

       48
       +
         | `O pairs ->

     

       49
       +
             `O (Mapping.make (List.map (fun (k, v) ->

     

       50
       +
               (`Scalar (Scalar.make k), of_value v)

     

       51
       +
             ) pairs))

     

       52
       +
       

     

       53
       +
       (** Convert to JSON-compatible Value *)

     

       54
       +
       

     

       55
       +
       let rec to_value (v : t) : Value.t =

     

       56
       +
         match v with

     

       57
       +
         | `Scalar s -> scalar_to_value s

     

       58
       +
         | `Alias name -> Error.raise (Unresolved_alias name)

     

       59
       +
         | `A seq -> `A (List.map to_value (Sequence.members seq))

     

       60
       +
         | `O map ->

     

       61
       +
             `O (List.map (fun (k, v) ->

     

       62
       +
               let key = match k with

     

       63
       +
                 | `Scalar s -> Scalar.value s

     

       64
       +
                 | _ -> Error.raise (Type_mismatch ("string key", "complex key"))

     

       65
       +
               in

     

       66
       +
               (key, to_value v)

     

       67
       +
             ) (Mapping.members map))

     

       68
       +
       

     

       69
       +
       (** Convert scalar to JSON value based on content *)

     

       70
       +
       and scalar_to_value s =

     

       71
       +
         let value = Scalar.value s in

     

       72
       +
         let tag = Scalar.tag s in

     

       73
       +
         let style = Scalar.style s in

     

       74
       +
       

     

       75
       +
         (* If explicitly tagged, respect the tag *)

     

       76
       +
         match tag with

     

       77
       +
         | Some "tag:yaml.org,2002:null" | Some "!!null" ->

     

       78
       +
             `Null

     

       79
       +
         | Some "tag:yaml.org,2002:bool" | Some "!!bool" ->

     

       80
       +
             (match String.lowercase_ascii value with

     

       81
       +
              | "true" | "yes" | "on" -> `Bool true

     

       82
       +
              | "false" | "no" | "off" -> `Bool false

     

       83
       +
              | _ -> Error.raise (Invalid_scalar_conversion (value, "bool")))

     

       84
       +
         | Some "tag:yaml.org,2002:int" | Some "!!int" ->

     

       85
       +
             (try `Float (Float.of_string value)

     

       86
       +
              with _ -> Error.raise (Invalid_scalar_conversion (value, "int")))

     

       87
       +
         | Some "tag:yaml.org,2002:float" | Some "!!float" ->

     

       88
       +
             (try `Float (Float.of_string value)

     

       89
       +
              with _ -> Error.raise (Invalid_scalar_conversion (value, "float")))

     

       90
       +
         | Some "tag:yaml.org,2002:str" | Some "!!str" ->

     

       91
       +
             `String value

     

       92
       +
         | Some _ ->

     

       93
       +
             (* Unknown tag - treat as string *)

     

       94
       +
             `String value

     

       95
       +
         | None ->

     

       96
       +
             (* Implicit type resolution for plain scalars *)

     

       97
       +
             if style <> Scalar_style.Plain then

     

       98
       +
               `String value

     

       99
       +
             else

     

       100
       +
               infer_scalar_type value

     

       101
       +
       

     

       102
       +
       (** Infer type from plain scalar value *)

     

       103
       +
       and infer_scalar_type value =

     

       104
       +
         let lower = String.lowercase_ascii value in

     

       105
       +
         (* Null *)

     

       106
       +
         if value = "" || lower = "null" || lower = "~" then

     

       107
       +
           `Null

     

       108
       +
         (* Boolean *)

     

       109
       +
         else if lower = "true" || lower = "yes" || lower = "on" then

     

       110
       +
           `Bool true

     

       111
       +
         else if lower = "false" || lower = "no" || lower = "off" then

     

       112
       +
           `Bool false

     

       113
       +
         (* Special floats *)

     

       114
       +
         else if lower = ".inf" || lower = "+.inf" then

     

       115
       +
           `Float Float.infinity

     

       116
       +
         else if lower = "-.inf" then

     

       117
       +
           `Float Float.neg_infinity

     

       118
       +
         else if lower = ".nan" then

     

       119
       +
           `Float Float.nan

     

       120
       +
         (* Try numeric *)

     

       121
       +
         else

     

       122
       +
           try_parse_number value

     

       123
       +
       

     

       124
       +
       (** Try to parse as number *)

     

       125
       +
       and try_parse_number value =

     

       126
       +
         (* Try integer first *)

     

       127
       +
         let try_int () =

     

       128
       +
           if String.length value > 0 then

     

       129
       +
             let first = value.[0] in

     

       130
       +
             if first = '-' || first = '+' || (first >= '0' && first <= '9') then

     

       131
       +
               try

     

       132
       +
                 (* Handle octal: 0o prefix or leading 0 *)

     

       133
       +
                 if String.length value > 2 && value.[0] = '0' then

     

       134
       +
                   match value.[1] with

     

       135
       +
                   | 'x' | 'X' ->

     

       136
       +
                       (* Hex *)

     

       137
       +
                       Some (`Float (Float.of_int (int_of_string value)))

     

       138
       +
                   | 'o' | 'O' ->

     

       139
       +
                       (* Octal *)

     

       140
       +
                       Some (`Float (Float.of_int (int_of_string value)))

     

       141
       +
                   | 'b' | 'B' ->

     

       142
       +
                       (* Binary *)

     

       143
       +
                       Some (`Float (Float.of_int (int_of_string value)))

     

       144
       +
                   | _ ->

     

       145
       +
                       (* Decimal with leading zero or octal in YAML 1.1 *)

     

       146
       +
                       Some (`Float (Float.of_string value))

     

       147
       +
                 else

     

       148
       +
                   Some (`Float (Float.of_string value))

     

       149
       +
               with _ -> None

     

       150
       +
             else None

     

       151
       +
           else None

     

       152
       +
         in

     

       153
       +
         match try_int () with

     

       154
       +
         | Some v -> v

     

       155
       +
         | None ->

     

       156
       +
             (* Try float *)

     

       157
       +
             try

     

       158
       +
               let f = Float.of_string value in

     

       159
       +
               `Float f

     

       160
       +
             with _ ->

     

       161
       +
               (* Not a number - it's a string *)

     

       162
       +
               `String value

     

       163
       +
       

     

       164
       +
       (** Resolve aliases by replacing them with referenced nodes *)

     

       165
       +
       

     

       166
       +
       let resolve_aliases (root : t) : t =

     

       167
       +
         let anchors = Hashtbl.create 16 in

     

       168
       +
       

     

       169
       +
         (* First pass: collect all anchors *)

     

       170
       +
         let rec collect (v : t) =

     

       171
       +
           match v with

     

       172
       +
           | `Scalar s ->

     

       173
       +
               (match Scalar.anchor s with

     

       174
       +
                | Some name -> Hashtbl.replace anchors name v

     

       175
       +
                | None -> ())

     

       176
       +
           | `Alias _ -> ()

     

       177
       +
           | `A seq ->

     

       178
       +
               (match Sequence.anchor seq with

     

       179
       +
                | Some name -> Hashtbl.replace anchors name v

     

       180
       +
                | None -> ());

     

       181
       +
               List.iter collect (Sequence.members seq)

     

       182
       +
           | `O map ->

     

       183
       +
               (match Mapping.anchor map with

     

       184
       +
                | Some name -> Hashtbl.replace anchors name v

     

       185
       +
                | None -> ());

     

       186
       +
               List.iter (fun (k, v) -> collect k; collect v) (Mapping.members map)

     

       187
       +
         in

     

       188
       +
         collect root;

     

       189
       +
       

     

       190
       +
         (* Second pass: resolve aliases *)

     

       191
       +
         let rec resolve (v : t) : t =

     

       192
       +
           match v with

     

       193
       +
           | `Scalar _ -> v

     

       194
       +
           | `Alias name ->

     

       195
       +
               (match Hashtbl.find_opt anchors name with

     

       196
       +
                | Some target -> resolve target

     

       197
       +
                | None -> Error.raise (Undefined_alias name))

     

       198
       +
           | `A seq ->

     

       199
       +
               `A (Sequence.map resolve seq)

     

       200
       +
           | `O map ->

     

       201
       +
               `O (Mapping.make

     

       202
       +
                     ?anchor:(Mapping.anchor map)

     

       203
       +
                     ?tag:(Mapping.tag map)

     

       204
       +
                     ~implicit:(Mapping.implicit map)

     

       205
       +
                     ~style:(Mapping.style map)

     

       206
       +
                     (List.map (fun (k, v) -> (resolve k, resolve v)) (Mapping.members map)))

     

       207
       +
         in

     

       208
       +
         resolve root

     

       209
       +
       

     

       210
       +
       (** Get anchor from any node *)

     

       211
       +
       let anchor (v : t) =

     

       212
       +
         match v with

     

       213
       +
         | `Scalar s -> Scalar.anchor s

     

       214
       +
         | `Alias _ -> None

     

       215
       +
         | `A seq -> Sequence.anchor seq

     

       216
       +
         | `O map -> Mapping.anchor map

     

       217
       +
       

     

       218
       +
       (** Get tag from any node *)

     

       219
       +
       let tag (v : t) =

     

       220
       +
         match v with

     

       221
       +
         | `Scalar s -> Scalar.tag s

     

       222
       +
         | `Alias _ -> None

     

       223
       +
         | `A seq -> Sequence.tag seq

     

       224
       +
         | `O map -> Mapping.tag map

+149

yaml/ocaml-yamle/lib/yamle.ml

···

       1
       +
       type value = Value.t

     

       2
       +
       type yaml = Yaml.t

     

       3
       +
       

     

       4
       +
       type version = [ `V1_1 | `V1_2 ]

     

       5
       +
       

     

       6
       +
       type encoding = Encoding.t

     

       7
       +
       type scalar_style = Scalar_style.t

     

       8
       +
       type layout_style = Layout_style.t

     

       9
       +
       

     

       10
       +
       (** {1 Error handling} *)

     

       11
       +
       

     

       12
       +
       type error = Error.t

     

       13
       +
       exception Yamle_error = Error.Yamle_error

     

       14
       +
       

     

       15
       +
       (** {1 JSON-compatible parsing} *)

     

       16
       +
       

     

       17
       +
       let of_string s = Loader.value_of_string s

     

       18
       +
       

     

       19
       +
       (** {1 JSON-compatible emission} *)

     

       20
       +
       

     

       21
       +
       let to_string

     

       22
       +
           ?(encoding = Encoding.Utf8)

     

       23
       +
           ?(scalar_style = Scalar_style.Any)

     

       24
       +
           ?(layout_style = Layout_style.Any)

     

       25
       +
           value =

     

       26
       +
         let config = {

     

       27
       +
           Emitter.default_config with

     

       28
       +
           encoding;

     

       29
       +
           scalar_style;

     

       30
       +
           layout_style;

     

       31
       +
         } in

     

       32
       +
         Emitter.value_to_string ~config value

     

       33
       +
       

     

       34
       +
       (** {1 YAML-specific parsing} *)

     

       35
       +
       

     

       36
       +
       let yaml_of_string s = Loader.yaml_of_string s

     

       37
       +
       

     

       38
       +
       (** {1 YAML-specific emission} *)

     

       39
       +
       

     

       40
       +
       let yaml_to_string

     

       41
       +
           ?(encoding = Encoding.Utf8)

     

       42
       +
           ?(scalar_style = Scalar_style.Any)

     

       43
       +
           ?(layout_style = Layout_style.Any)

     

       44
       +
           yaml =

     

       45
       +
         let config = {

     

       46
       +
           Emitter.default_config with

     

       47
       +
           encoding;

     

       48
       +
           scalar_style;

     

       49
       +
           layout_style;

     

       50
       +
         } in

     

       51
       +
         Emitter.yaml_to_string ~config yaml

     

       52
       +
       

     

       53
       +
       (** {1 Conversion} *)

     

       54
       +
       

     

       55
       +
       let to_json yaml = Yaml.to_value yaml

     

       56
       +
       

     

       57
       +
       let of_json value = Yaml.of_value value

     

       58
       +
       

     

       59
       +
       (** {1 Pretty printing} *)

     

       60
       +
       

     

       61
       +
       let pp = Value.pp

     

       62
       +
       let pp_yaml = Yaml.pp

     

       63
       +
       let equal = Value.equal

     

       64
       +
       let equal_yaml = Yaml.equal

     

       65
       +
       

     

       66
       +
       (** {1 Nested modules} *)

     

       67
       +
       

     

       68
       +
       module Error = Error

     

       69
       +
       module Position = Position

     

       70
       +
       module Span = Span

     

       71
       +
       module Encoding = Encoding

     

       72
       +
       module Input = Input

     

       73
       +
       module Scalar_style = Scalar_style

     

       74
       +
       module Layout_style = Layout_style

     

       75
       +
       module Chomping = Chomping

     

       76
       +
       module Token = Token

     

       77
       +
       module Scanner = Scanner

     

       78
       +
       module Event = Event

     

       79
       +
       module Parser = Parser

     

       80
       +
       module Tag = Tag

     

       81
       +
       module Value = Value

     

       82
       +
       module Scalar = Scalar

     

       83
       +
       module Sequence = Sequence

     

       84
       +
       module Mapping = Mapping

     

       85
       +
       module Yaml = Yaml

     

       86
       +
       module Document = Document

     

       87
       +
       module Loader = Loader

     

       88
       +
       module Emitter = Emitter

     

       89
       +
       

     

       90
       +
       (** {1 Streaming interface} *)

     

       91
       +
       

     

       92
       +
       module Stream = struct

     

       93
       +
         type parser = Parser.t

     

       94
       +
         type emitter = Emitter.t

     

       95
       +
       

     

       96
       +
         let parser s = Parser.of_string s

     

       97
       +
       

     

       98
       +
         let do_parse p = Parser.next p

     

       99
       +
       

     

       100
       +
         let emitter ?len:_ () = Emitter.create ()

     

       101
       +
       

     

       102
       +
         let emit e ev = Emitter.emit e ev

     

       103
       +
       

     

       104
       +
         let emitter_buf e = Emitter.contents e

     

       105
       +
       

     

       106
       +
         (** Convenience event emitters *)

     

       107
       +
       

     

       108
       +
         let stream_start e enc =

     

       109
       +
           Emitter.emit e (Event.Stream_start { encoding = enc })

     

       110
       +
       

     

       111
       +
         let stream_end e =

     

       112
       +
           Emitter.emit e Event.Stream_end

     

       113
       +
       

     

       114
       +
         let document_start ?version ?(implicit = true) e =

     

       115
       +
           let version = match version with

     

       116
       +
             | Some `V1_1 -> Some (1, 1)

     

       117
       +
             | Some `V1_2 -> Some (1, 2)

     

       118
       +
             | None -> None

     

       119
       +
           in

     

       120
       +
           Emitter.emit e (Event.Document_start { version; implicit })

     

       121
       +
       

     

       122
       +
         let document_end ?(implicit = true) e =

     

       123
       +
           Emitter.emit e (Event.Document_end { implicit })

     

       124
       +
       

     

       125
       +
         let scalar s e =

     

       126
       +
           Emitter.emit e (Event.Scalar {

     

       127
       +
             anchor = Scalar.anchor s;

     

       128
       +
             tag = Scalar.tag s;

     

       129
       +
             value = Scalar.value s;

     

       130
       +
             plain_implicit = Scalar.plain_implicit s;

     

       131
       +
             quoted_implicit = Scalar.quoted_implicit s;

     

       132
       +
             style = Scalar.style s;

     

       133
       +
           })

     

       134
       +
       

     

       135
       +
         let alias e name =

     

       136
       +
           Emitter.emit e (Event.Alias { anchor = name })

     

       137
       +
       

     

       138
       +
         let sequence_start ?anchor ?tag ?(implicit = true) ?(style = Layout_style.Any) e =

     

       139
       +
           Emitter.emit e (Event.Sequence_start { anchor; tag; implicit; style })

     

       140
       +
       

     

       141
       +
         let sequence_end e =

     

       142
       +
           Emitter.emit e Event.Sequence_end

     

       143
       +
       

     

       144
       +
         let mapping_start ?anchor ?tag ?(implicit = true) ?(style = Layout_style.Any) e =

     

       145
       +
           Emitter.emit e (Event.Mapping_start { anchor; tag; implicit; style })

     

       146
       +
       

     

       147
       +
         let mapping_end e =

     

       148
       +
           Emitter.emit e Event.Mapping_end

     

       149
       +
       end

yaml/ocaml-yamle/tests/cram/dune

···

       1
       +
       (cram

     

       2
       +
        (deps

     

       3
       +
         (package yamle)

     

       4
       +
         ../yaml/seq.yml

     

       5
       +
         ../yaml/cohttp.yml

     

       6
       +
         ../yaml/linuxkit.yml

     

       7
       +
         ../yaml/yaml-1.2.yml))

+161

yaml/ocaml-yamle/tests/cram/yamlcat.t

···

       1
       +
       Test yamlcat with simple YAML

     

       2
       +
       

     

       3
       +
         $ echo 'hello: world' | yamlcat

     

       4
       +
         hello: world

     

       5
       +
       

     

       6
       +
         $ echo 'name: Alice

     

       7
       +
         > age: 30' | yamlcat

     

       8
       +
         name: Alice

     

       9
       +
         age: 30

     

       10
       +
       

     

       11
       +
       Test nested mappings

     

       12
       +
       

     

       13
       +
         $ echo 'server:

     

       14
       +
         >   host: localhost

     

       15
       +
         >   port: 8080

     

       16
       +
         > database:

     

       17
       +
         >   name: mydb' | yamlcat

     

       18
       +
         server:

     

       19
       +
           host: localhost

     

       20
       +
           port: 8080

     

       21
       +
         database:

     

       22
       +
           name: mydb

     

       23
       +
       

     

       24
       +
       Test sequences

     

       25
       +
       

     

       26
       +
         $ echo '- apple

     

       27
       +
         > - banana

     

       28
       +
         > - cherry' | yamlcat

     

       29
       +
         - apple

     

       30
       +
         - banana

     

       31
       +
         - cherry

     

       32
       +
       

     

       33
       +
       Test mapping with sequence value

     

       34
       +
       

     

       35
       +
         $ echo 'fruits:

     

       36
       +
         >   - apple

     

       37
       +
         >   - banana' | yamlcat

     

       38
       +
         fruits:

     

       39
       +
           - apple

     

       40
       +
           - banana

     

       41
       +
       

     

       42
       +
       Test flow style output

     

       43
       +
       

     

       44
       +
         $ echo 'name: Alice

     

       45
       +
         > hobbies:

     

       46
       +
         >   - reading

     

       47
       +
         >   - coding' | yamlcat --flow

     

       48
       +
         {name: Alice, hobbies: [reading, coding]}

     

       49
       +
       

     

       50
       +
       Test JSON output

     

       51
       +
       

     

       52
       +
         $ echo 'name: Alice

     

       53
       +
         > age: 30' | yamlcat --json

     

       54
       +
         {"name": "Alice", "age": 30}

     

       55
       +
       

     

       56
       +
       Test seq.yml file (multiline plain scalar)

     

       57
       +
       

     

       58
       +
         $ yamlcat ../yaml/seq.yml

     

       59
       +
         - hello  - whats  - up

     

       60
       +
         - foo

     

       61
       +
         - bar

     

       62
       +
       

     

       63
       +
       Test seq.yml roundtrip preserves data

     

       64
       +
       

     

       65
       +
         $ yamlcat --json ../yaml/seq.yml

     

       66
       +
         ["hello  - whats  - up", "foo", "bar"]

     

       67
       +
       

     

       68
       +
       Test cohttp.yml

     

       69
       +
       

     

       70
       +
         $ yamlcat ../yaml/cohttp.yml

     

       71
       +
         language: c

     

       72
       +
         sudo: false

     

       73
       +
         services:

     

       74
       +
           - docker

     

       75
       +
         install: 'wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh'

     

       76
       +
         script: bash -ex ./.travis-docker.sh

     

       77
       +
         env:

     

       78
       +
           global:

     

       79
       +
             - "EXTRA_REMOTES=\"https://github.com/mirage/mirage-dev.git\""

     

       80
       +
             - "PINS=\"cohttp-top:. cohttp-async:. cohttp-lwt-unix:. cohttp-lwt-jsoo:. cohttp-lwt:. cohttp-mirage:. cohttp:.\""

     

       81
       +
           matrix:

     

       82
       +
             - "PACKAGE=\"cohttp\" DISTRO=\"alpine-3.5\" OCAML_VERSION=\"4.06.0\""

     

       83
       +
             - "PACKAGE=\"cohttp-async\" DISTRO=\"alpine\" OCAML_VERSION=\"4.06.0\""

     

       84
       +
             - "PACKAGE=\"cohttp-lwt\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\""

     

       85
       +
             - "PACKAGE=\"cohttp-mirage\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\""

     

       86
       +
         notifications:

     

       87
       +
           webhooks:

     

       88
       +
             urls:

     

       89
       +
               - 'https://webhooks.gitter.im/e/6ee5059c7420709f4ad1'

     

       90
       +
             on_success: change

     

       91
       +
             on_failure: always

     

       92
       +
             on_start: false

     

       93
       +
       

     

       94
       +
       Test cohttp.yml roundtrip with JSON

     

       95
       +
       

     

       96
       +
         $ yamlcat --json ../yaml/cohttp.yml

     

       97
       +
         {"language": "c", "sudo": false, "services": ["docker"], "install": "wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh", "script": "bash -ex ./.travis-docker.sh", "env": {"global": ["EXTRA_REMOTES=\"https://github.com/mirage/mirage-dev.git\"", "PINS=\"cohttp-top:. cohttp-async:. cohttp-lwt-unix:. cohttp-lwt-jsoo:. cohttp-lwt:. cohttp-mirage:. cohttp:.\""], "matrix": ["PACKAGE=\"cohttp\" DISTRO=\"alpine-3.5\" OCAML_VERSION=\"4.06.0\"", "PACKAGE=\"cohttp-async\" DISTRO=\"alpine\" OCAML_VERSION=\"4.06.0\"", "PACKAGE=\"cohttp-lwt\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\"", "PACKAGE=\"cohttp-mirage\" DISTRO=\"debian-unstable\" OCAML_VERSION=\"4.03.0\""]}, "notifications": {"webhooks": {"urls": ["https://webhooks.gitter.im/e/6ee5059c7420709f4ad1"], "on_success": "change", "on_failure": "always", "on_start": false}}}

     

       98
       +
       

     

       99
       +
       Test special values

     

       100
       +
       

     

       101
       +
         $ echo 'null_val: null

     

       102
       +
         > bool_true: true

     

       103
       +
         > bool_false: false

     

       104
       +
         > number: 42

     

       105
       +
         > float: 3.14' | yamlcat --json

     

       106
       +
         {"null_val": null, "bool_true": true, "bool_false": false, "number": 42, "float": 3.14}

     

       107
       +
       

     

       108
       +
       Test quoted strings

     

       109
       +
       

     

       110
       +
         $ echo 'single: '"'"'hello world'"'"'

     

       111
       +
         > double: "hello world"' | yamlcat

     

       112
       +
         single: hello world

     

       113
       +
         double: hello world

     

       114
       +
       

     

       115
       +
       Test literal block scalar

     

       116
       +
       

     

       117
       +
         $ echo 'text: |

     

       118
       +
         >   line one

     

       119
       +
         >   line two' | yamlcat --json

     

       120
       +
         {"text": "line one\nline two\n"}

     

       121
       +
       

     

       122
       +
       Test folded block scalar

     

       123
       +
       

     

       124
       +
         $ echo 'text: >

     

       125
       +
         >   line one

     

       126
       +
         >   line two' | yamlcat --json

     

       127
       +
         {"text": "line one line two\n"}

     

       128
       +
       

     

       129
       +
       Test linuxkit.yml (sequences of mappings)

     

       130
       +
       

     

       131
       +
         $ yamlcat ../yaml/linuxkit.yml | head -30

     

       132
       +
         kernel:

     

       133
       +
           image: 'linuxkit/kernel:4.9.40'

     

       134
       +
           cmdline: console=tty0 console=ttyS0

     

       135
       +
         init:

     

       136
       +
           - 'linuxkit/init:906e174b3f2e07f97d6fd693a2e8518e98dafa58'

     

       137
       +
           - 'linuxkit/runc:90e45f13e1d0a0983f36ef854621e3eac91cf541'

     

       138
       +
           - 'linuxkit/containerd:7c986fb7df33bea73b5c8097b46989e46f49d875'

     

       139
       +
           - 'linuxkit/ca-certificates:e44b0a66df5a102c0e220f0066b0d904710dcb10'

     

       140
       +
         onboot:

     

       141
       +
           - name: sysctl

     

       142
       +
             image: 'linuxkit/sysctl:184c914d23a017062d7b53d7fc1dfaf47764bef6'

     

       143
       +
           - name: dhcpcd

     

       144
       +
             image: 'linuxkit/dhcpcd:f3f5413abb78fae9020e35bd4788fa93df4530b7'

     

       145
       +
             command:

     

       146
       +
               - /sbin/dhcpcd

     

       147
       +
               - '--nobackground'

     

       148
       +
               - '-f'

     

       149
       +
               - /dhcpcd.conf

     

       150
       +
               - '-1'

     

       151
       +
         onshutdown:

     

       152
       +
           - name: shutdown

     

       153
       +
             image: 'busybox:latest'

     

       154
       +
             command:

     

       155
       +
               - /bin/echo

     

       156
       +
               - so long and thanks for all the fish

     

       157
       +
         services:

     

       158
       +
           - name: getty

     

       159
       +
             image: 'linuxkit/getty:2c841cdc34396e3fa8f25b62d112808f63f16df6'

     

       160
       +
             env:

     

       161
       +
               - INSECURE=true

yaml/ocaml-yamle/tests/dune

···

       1
       +
       (test

     

       2
       +
        (name test_yamle)

     

       3
       +
        (libraries yamle alcotest))

+262

yaml/ocaml-yamle/tests/test_yamle.ml

···

       1
       +
       (** Tests for the Yamle library *)

     

       2
       +
       

     

       3
       +
       open Yamle

     

       4
       +
       

     

       5
       +
       (** Test helpers *)

     

       6
       +
       

     

       7
       +
       let check_value msg expected actual =

     

       8
       +
         Alcotest.(check bool) msg true (Value.equal expected actual)

     

       9
       +
       

     

       10
       +
       let _check_string msg expected actual =

     

       11
       +
         Alcotest.(check string) msg expected actual

     

       12
       +
       

     

       13
       +
       (** Scanner tests *)

     

       14
       +
       

     

       15
       +
       let test_scanner_simple () =

     

       16
       +
         let scanner = Scanner.of_string "hello: world" in

     

       17
       +
         let tokens = Scanner.to_list scanner in

     

       18
       +
         let token_types = List.map (fun (t : Token.spanned) -> t.token) tokens in

     

       19
       +
         Alcotest.(check int) "token count" 8 (List.length token_types);

     

       20
       +
         (* Stream_start, Block_mapping_start, Key, Scalar, Value, Scalar, Block_end, Stream_end *)

     

       21
       +
         match token_types with

     

       22
       +
         | Token.Stream_start _ :: Token.Block_mapping_start :: Token.Key ::

     

       23
       +
           Token.Scalar { value = "hello"; _ } :: Token.Value ::

     

       24
       +
           Token.Scalar { value = "world"; _ } :: Token.Block_end :: Token.Stream_end :: [] ->

     

       25
       +
             ()

     

       26
       +
         | _ ->

     

       27
       +
             Alcotest.fail "unexpected token sequence"

     

       28
       +
       

     

       29
       +
       let test_scanner_sequence () =

     

       30
       +
         let scanner = Scanner.of_string "- one\n- two\n- three" in

     

       31
       +
         let tokens = Scanner.to_list scanner in

     

       32
       +
         Alcotest.(check bool) "has tokens" true (List.length tokens > 0)

     

       33
       +
       

     

       34
       +
       let test_scanner_flow () =

     

       35
       +
         let scanner = Scanner.of_string "[1, 2, 3]" in

     

       36
       +
         let tokens = Scanner.to_list scanner in

     

       37
       +
         let has_flow_start = List.exists (fun (t : Token.spanned) ->

     

       38
       +
           match t.token with Token.Flow_sequence_start -> true | _ -> false

     

       39
       +
         ) tokens in

     

       40
       +
         Alcotest.(check bool) "has flow sequence start" true has_flow_start

     

       41
       +
       

     

       42
       +
       let scanner_tests = [

     

       43
       +
         "simple mapping", `Quick, test_scanner_simple;

     

       44
       +
         "sequence", `Quick, test_scanner_sequence;

     

       45
       +
         "flow sequence", `Quick, test_scanner_flow;

     

       46
       +
       ]

     

       47
       +
       

     

       48
       +
       (** Parser tests *)

     

       49
       +
       

     

       50
       +
       let test_parser_events () =

     

       51
       +
         let parser = Parser.of_string "key: value" in

     

       52
       +
         let events = Parser.to_list parser in

     

       53
       +
         Alcotest.(check bool) "has events" true (List.length events > 0);

     

       54
       +
         let has_stream_start = List.exists (fun (e : Event.spanned) ->

     

       55
       +
           match e.event with Event.Stream_start _ -> true | _ -> false

     

       56
       +
         ) events in

     

       57
       +
         Alcotest.(check bool) "has stream start" true has_stream_start

     

       58
       +
       

     

       59
       +
       let test_parser_sequence_events () =

     

       60
       +
         let parser = Parser.of_string "- a\n- b" in

     

       61
       +
         let events = Parser.to_list parser in

     

       62
       +
         let has_seq_start = List.exists (fun (e : Event.spanned) ->

     

       63
       +
           match e.event with Event.Sequence_start _ -> true | _ -> false

     

       64
       +
         ) events in

     

       65
       +
         Alcotest.(check bool) "has sequence start" true has_seq_start

     

       66
       +
       

     

       67
       +
       let parser_tests = [

     

       68
       +
         "parse events", `Quick, test_parser_events;

     

       69
       +
         "sequence events", `Quick, test_parser_sequence_events;

     

       70
       +
       ]

     

       71
       +
       

     

       72
       +
       (** Value parsing tests *)

     

       73
       +
       

     

       74
       +
       let test_parse_null () =

     

       75
       +
         check_value "null" `Null (of_string "null");

     

       76
       +
         check_value "~" `Null (of_string "~");

     

       77
       +
         check_value "empty" `Null (of_string "")

     

       78
       +
       

     

       79
       +
       let test_parse_bool () =

     

       80
       +
         check_value "true" (`Bool true) (of_string "true");

     

       81
       +
         check_value "false" (`Bool false) (of_string "false");

     

       82
       +
         check_value "yes" (`Bool true) (of_string "yes");

     

       83
       +
         check_value "no" (`Bool false) (of_string "no")

     

       84
       +
       

     

       85
       +
       let test_parse_number () =

     

       86
       +
         check_value "integer" (`Float 42.0) (of_string "42");

     

       87
       +
         check_value "negative" (`Float (-17.0)) (of_string "-17");

     

       88
       +
         check_value "float" (`Float 3.14) (of_string "3.14")

     

       89
       +
       

     

       90
       +
       let test_parse_string () =

     

       91
       +
         check_value "plain" (`String "hello") (of_string "hello world" |> function `String s -> `String (String.sub s 0 5) | v -> v);

     

       92
       +
         check_value "quoted" (`String "hello") (of_string {|"hello"|})

     

       93
       +
       

     

       94
       +
       let test_parse_sequence () =

     

       95
       +
         let result = of_string "- one\n- two\n- three" in

     

       96
       +
         match result with

     

       97
       +
         | `A [_; _; _] -> ()

     

       98
       +
         | _ -> Alcotest.fail "expected sequence with 3 elements"

     

       99
       +
       

     

       100
       +
       let test_parse_mapping () =

     

       101
       +
         let result = of_string "name: Alice\nage: 30" in

     

       102
       +
         match result with

     

       103
       +
         | `O pairs when List.length pairs = 2 -> ()

     

       104
       +
         | _ -> Alcotest.fail "expected mapping with 2 pairs"

     

       105
       +
       

     

       106
       +
       let test_parse_nested () =

     

       107
       +
         let yaml = {|

     

       108
       +
       person:

     

       109
       +
         name: Bob

     

       110
       +
         hobbies:

     

       111
       +
           - reading

     

       112
       +
           - coding

     

       113
       +
       |} in

     

       114
       +
         let result = of_string yaml in

     

       115
       +
         match result with

     

       116
       +
         | `O [("person", `O _)] -> ()

     

       117
       +
         | _ -> Alcotest.fail "expected nested structure"

     

       118
       +
       

     

       119
       +
       let test_parse_flow_sequence () =

     

       120
       +
         let result = of_string "[1, 2, 3]" in

     

       121
       +
         match result with

     

       122
       +
         | `A [`Float 1.0; `Float 2.0; `Float 3.0] -> ()

     

       123
       +
         | _ -> Alcotest.fail "expected flow sequence [1, 2, 3]"

     

       124
       +
       

     

       125
       +
       let test_parse_flow_mapping () =

     

       126
       +
         let result = of_string "{a: 1, b: 2}" in

     

       127
       +
         match result with

     

       128
       +
         | `O [("a", `Float 1.0); ("b", `Float 2.0)] -> ()

     

       129
       +
         | _ -> Alcotest.fail "expected flow mapping {a: 1, b: 2}"

     

       130
       +
       

     

       131
       +
       let value_tests = [

     

       132
       +
         "parse null", `Quick, test_parse_null;

     

       133
       +
         "parse bool", `Quick, test_parse_bool;

     

       134
       +
         "parse number", `Quick, test_parse_number;

     

       135
       +
         "parse string", `Quick, test_parse_string;

     

       136
       +
         "parse sequence", `Quick, test_parse_sequence;

     

       137
       +
         "parse mapping", `Quick, test_parse_mapping;

     

       138
       +
         "parse nested", `Quick, test_parse_nested;

     

       139
       +
         "parse flow sequence", `Quick, test_parse_flow_sequence;

     

       140
       +
         "parse flow mapping", `Quick, test_parse_flow_mapping;

     

       141
       +
       ]

     

       142
       +
       

     

       143
       +
       (** Emitter tests *)

     

       144
       +
       

     

       145
       +
       let test_emit_null () =

     

       146
       +
         let result = to_string `Null in

     

       147
       +
         Alcotest.(check bool) "contains null" true (String.length result > 0)

     

       148
       +
       

     

       149
       +
       let starts_with prefix s =

     

       150
       +
         String.length s >= String.length prefix &&

     

       151
       +
         String.sub s 0 (String.length prefix) = prefix

     

       152
       +
       

     

       153
       +
       let test_emit_mapping () =

     

       154
       +
         let value = `O [("name", `String "Alice"); ("age", `Float 30.0)] in

     

       155
       +
         let result = to_string value in

     

       156
       +
         let trimmed = String.trim result in

     

       157
       +
         Alcotest.(check bool) "contains name" true (starts_with "name" trimmed || starts_with "\"name\"" trimmed)

     

       158
       +
       

     

       159
       +
       let test_roundtrip_simple () =

     

       160
       +
         let yaml = "name: Alice" in

     

       161
       +
         let value = of_string yaml in

     

       162
       +
         let _ = to_string value in

     

       163
       +
         (* Just check it doesn't crash *)

     

       164
       +
         ()

     

       165
       +
       

     

       166
       +
       let test_roundtrip_sequence () =

     

       167
       +
         let yaml = "- one\n- two\n- three" in

     

       168
       +
         let value = of_string yaml in

     

       169
       +
         match value with

     

       170
       +
         | `A items when List.length items = 3 ->

     

       171
       +
             let _ = to_string value in

     

       172
       +
             ()

     

       173
       +
         | _ -> Alcotest.fail "roundtrip failed"

     

       174
       +
       

     

       175
       +
       let emitter_tests = [

     

       176
       +
         "emit null", `Quick, test_emit_null;

     

       177
       +
         "emit mapping", `Quick, test_emit_mapping;

     

       178
       +
         "roundtrip simple", `Quick, test_roundtrip_simple;

     

       179
       +
         "roundtrip sequence", `Quick, test_roundtrip_sequence;

     

       180
       +
       ]

     

       181
       +
       

     

       182
       +
       (** YAML-specific tests *)

     

       183
       +
       

     

       184
       +
       let test_yaml_anchor () =

     

       185
       +
         let yaml = "&anchor hello" in

     

       186
       +
         let result = yaml_of_string yaml in

     

       187
       +
         match result with

     

       188
       +
         | `Scalar s when Scalar.anchor s = Some "anchor" -> ()

     

       189
       +
         | _ -> Alcotest.fail "expected scalar with anchor"

     

       190
       +
       

     

       191
       +
       let test_yaml_alias () =

     

       192
       +
         let yaml = {|

     

       193
       +
       defaults: &defaults

     

       194
       +
         timeout: 30

     

       195
       +
       production:

     

       196
       +
         <<: *defaults

     

       197
       +
         port: 8080

     

       198
       +
       |} in

     

       199
       +
         (* Just check it parses without error *)

     

       200
       +
         let _ = yaml_of_string yaml in

     

       201
       +
         ()

     

       202
       +
       

     

       203
       +
       let yaml_tests = [

     

       204
       +
         "yaml anchor", `Quick, test_yaml_anchor;

     

       205
       +
         "yaml alias", `Quick, test_yaml_alias;

     

       206
       +
       ]

     

       207
       +
       

     

       208
       +
       (** Multiline scalar tests *)

     

       209
       +
       

     

       210
       +
       let test_literal_block () =

     

       211
       +
         let yaml = {|description: |

     

       212
       +
         This is a

     

       213
       +
         multi-line

     

       214
       +
         description

     

       215
       +
       |} in

     

       216
       +
         let result = of_string yaml in

     

       217
       +
         match result with

     

       218
       +
         | `O [("description", `String _)] -> ()

     

       219
       +
         | _ -> Alcotest.fail "expected mapping with literal block"

     

       220
       +
       

     

       221
       +
       let test_folded_block () =

     

       222
       +
         let yaml = {|description: >

     

       223
       +
         This is a

     

       224
       +
         folded

     

       225
       +
         description

     

       226
       +
       |} in

     

       227
       +
         let result = of_string yaml in

     

       228
       +
         match result with

     

       229
       +
         | `O [("description", `String _)] -> ()

     

       230
       +
         | _ -> Alcotest.fail "expected mapping with folded block"

     

       231
       +
       

     

       232
       +
       let multiline_tests = [

     

       233
       +
         "literal block", `Quick, test_literal_block;

     

       234
       +
         "folded block", `Quick, test_folded_block;

     

       235
       +
       ]

     

       236
       +
       

     

       237
       +
       (** Error handling tests *)

     

       238
       +
       

     

       239
       +
       let test_error_position () =

     

       240
       +
         try

     

       241
       +
           let _ = of_string "key: [unclosed" in

     

       242
       +
           Alcotest.fail "expected error"

     

       243
       +
         with

     

       244
       +
         | Yamle_error e ->

     

       245
       +
             Alcotest.(check bool) "has span" true (e.span <> None)

     

       246
       +
       

     

       247
       +
       let error_tests = [

     

       248
       +
         "error position", `Quick, test_error_position;

     

       249
       +
       ]

     

       250
       +
       

     

       251
       +
       (** Run all tests *)

     

       252
       +
       

     

       253
       +
       let () =

     

       254
       +
         Alcotest.run "yamle" [

     

       255
       +
           "scanner", scanner_tests;

     

       256
       +
           "parser", parser_tests;

     

       257
       +
           "value", value_tests;

     

       258
       +
           "emitter", emitter_tests;

     

       259
       +
           "yaml", yaml_tests;

     

       260
       +
           "multiline", multiline_tests;

     

       261
       +
           "errors", error_tests;

     

       262
       +
         ]

+24

yaml/ocaml-yamle/tests/yaml/anchor.yml

···

       1
       +
       datetime: 2001-12-15T02:59:43.1Z

     

       2
       +
       datetime_with_spaces: 2001-12-14 21:59:43.10 -5

     

       3
       +
       date: 2002-12-14

     

       4
       +
       

     

       5
       +
       # The !!binary tag indicates that a string is actually a base64-encoded

     

       6
       +
       # representation of a binary blob.

     

       7
       +
       gif_file: !!binary |

     

       8
       +
           R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5

     

       9
       +
           OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+

     

       10
       +
           +f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC

     

       11
       +
           AgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=

     

       12
       +
       

     

       13
       +
       # YAML also has a set type, which looks like this:

     

       14
       +
       set:

     

       15
       +
           ? item1

     

       16
       +
           ? item2

     

       17
       +
           ? item3

     

       18
       +
       

     

       19
       +
       # Like Python, sets are just maps with null values; the above is equivalent to:

     

       20
       +
       set2:

     

       21
       +
           item1: null

     

       22
       +
           item2: null

     

       23
       +
           item3: null

     

       24
       +

+23

yaml/ocaml-yamle/tests/yaml/cohttp.yml

···

       1
       +
       language: c

     

       2
       +
       sudo: false

     

       3
       +
       services:

     

       4
       +
         - docker

     

       5
       +
       install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh

     

       6
       +
       script: bash -ex ./.travis-docker.sh

     

       7
       +
       env:

     

       8
       +
         global:

     

       9
       +
         - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git"

     

       10
       +
         - PINS="cohttp-top:. cohttp-async:. cohttp-lwt-unix:. cohttp-lwt-jsoo:. cohttp-lwt:. cohttp-mirage:. cohttp:."

     

       11
       +
         matrix:

     

       12
       +
         - PACKAGE="cohttp" DISTRO="alpine-3.5" OCAML_VERSION="4.06.0"

     

       13
       +
         - PACKAGE="cohttp-async" DISTRO="alpine" OCAML_VERSION="4.06.0"

     

       14
       +
         - PACKAGE="cohttp-lwt" DISTRO="debian-unstable" OCAML_VERSION="4.03.0"

     

       15
       +
         - PACKAGE="cohttp-mirage" DISTRO="debian-unstable" OCAML_VERSION="4.03.0"

     

       16
       +
       notifications:

     

       17
       +
         webhooks:

     

       18
       +
           urls:

     

       19
       +
             - https://webhooks.gitter.im/e/6ee5059c7420709f4ad1

     

       20
       +
           on_success: change

     

       21
       +
           on_failure: always

     

       22
       +
           on_start: false

     

       23
       +

+59

yaml/ocaml-yamle/tests/yaml/linuxkit.yml

···

       1
       +
       kernel:

     

       2
       +
         image: linuxkit/kernel:4.9.40

     

       3
       +
         cmdline: "console=tty0 console=ttyS0"

     

       4
       +
       init:

     

       5
       +
         - linuxkit/init:906e174b3f2e07f97d6fd693a2e8518e98dafa58

     

       6
       +
         - linuxkit/runc:90e45f13e1d0a0983f36ef854621e3eac91cf541

     

       7
       +
         - linuxkit/containerd:7c986fb7df33bea73b5c8097b46989e46f49d875

     

       8
       +
         - linuxkit/ca-certificates:e44b0a66df5a102c0e220f0066b0d904710dcb10

     

       9
       +
       onboot:

     

       10
       +
         - name: sysctl

     

       11
       +
           image: linuxkit/sysctl:184c914d23a017062d7b53d7fc1dfaf47764bef6

     

       12
       +
         - name: dhcpcd

     

       13
       +
           image: linuxkit/dhcpcd:f3f5413abb78fae9020e35bd4788fa93df4530b7

     

       14
       +
           command: ["/sbin/dhcpcd", "--nobackground", "-f", "/dhcpcd.conf", "-1"]

     

       15
       +
       onshutdown:

     

       16
       +
         - name: shutdown

     

       17
       +
           image: busybox:latest

     

       18
       +
           command: ["/bin/echo", "so long and thanks for all the fish"]

     

       19
       +
       services:

     

       20
       +
         - name: getty

     

       21
       +
           image: linuxkit/getty:2c841cdc34396e3fa8f25b62d112808f63f16df6

     

       22
       +
           env:

     

       23
       +
            - INSECURE=true

     

       24
       +
         - name: rngd

     

       25
       +
           image: linuxkit/rngd:b2f4bdcb55aa88a25c86733e294628614504f383

     

       26
       +
         - name: nginx

     

       27
       +
           image: nginx:alpine

     

       28
       +
           capabilities:

     

       29
       +
            - CAP_NET_BIND_SERVICE

     

       30
       +
            - CAP_CHOWN

     

       31
       +
            - CAP_SETUID

     

       32
       +
            - CAP_SETGID

     

       33
       +
            - CAP_DAC_OVERRIDE

     

       34
       +
       files:

     

       35
       +
         - path: etc/containerd/config.toml

     

       36
       +
           contents: |

     

       37
       +
             state = "/run/containerd"

     

       38
       +
             root = "/var/lib/containerd"

     

       39
       +
             snapshotter = "io.containerd.snapshotter.v1.overlayfs"

     

       40
       +
             differ = "io.containerd.differ.v1.base-diff"

     

       41
       +
             subreaper = false

     

       42
       +
       

     

       43
       +
             [grpc]

     

       44
       +
             address = "/run/containerd/containerd.sock"

     

       45
       +
             uid = 0

     

       46
       +
             gid = 0

     

       47
       +
       

     

       48
       +
             [debug]

     

       49
       +
             address = "/run/containerd/debug.sock"

     

       50
       +
             level = "info"

     

       51
       +
       

     

       52
       +
             [metrics]

     

       53
       +
             address = ":13337"

     

       54
       +
         - path: etc/linuxkit-config

     

       55
       +
           metadata: yaml

     

       56
       +
       trust:

     

       57
       +
         org:

     

       58
       +
           - linuxkit

     

       59
       +
           - library

yaml/ocaml-yamle/tests/yaml/seq.yml

yaml/ocaml-yamle/tests/yaml/yaml-1.2.yml

···

       1
       +
       - {"when the key is quoted":"space after colon can be omitted."}

     

       2
       +
       - "quoted slashes \/ are allowed."

     

       3
       +
       - {?"a key can be looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooger": "than 1024 when parsing is unambiguous before seeing the colon."}

+32

yaml/ocaml-yamle/yamle.opam

···

       1
       +
       # This file is generated by dune, edit dune-project instead

     

       2
       +
       opam-version: "2.0"

     

       3
       +
       version: "0.1.0"

     

       4
       +
       synopsis: "Pure OCaml YAML 1.2 parser and emitter"

     

       5
       +
       description:

     

       6
       +
         "A pure OCaml implementation of YAML 1.2 parsing and emission, with no C dependencies."

     

       7
       +
       maintainer: ["yamle@example.com"]

     

       8
       +
       authors: ["Yamle Authors"]

     

       9
       +
       license: "ISC"

     

       10
       +
       homepage: "https://github.com/ocaml/yamle"

     

       11
       +
       bug-reports: "https://github.com/ocaml/yamle/issues"

     

       12
       +
       depends: [

     

       13
       +
         "ocaml" {>= "4.14.0"}

     

       14
       +
         "dune" {>= "3.0" & >= "3.0"}

     

       15
       +
         "alcotest" {with-test}

     

       16
       +
         "odoc" {with-doc}

     

       17
       +
       ]

     

       18
       +
       build: [

     

       19
       +
         ["dune" "subst"] {dev}

     

       20
       +
         [

     

       21
       +
           "dune"

     

       22
       +
           "build"

     

       23
       +
           "-p"

     

       24
       +
           name

     

       25
       +
           "-j"

     

       26
       +
           jobs

     

       27
       +
           "@install"

     

       28
       +
           "@runtest" {with-test}

     

       29
       +
           "@doc" {with-doc}

     

       30
       +
         ]

     

       31
       +
       ]

     

       32
       +
       dev-repo: "git+https://github.com/ocaml/yamle.git"