Source file ThunkParsers.ml

(** Parser utilities and simple parsers useful for testing lexers. The real
    parsers are in the modules that define the parsed type like {!ThunkCommand}.
*)

module Results = struct
  (** [pp_pos file].

      The format conforms to
      {{:https://github.com/microsoft/vscode/blob/d2bd76b5cad77e4d380853533014bc9f94ef0405/src/vs/workbench/contrib/terminalContrib/links/test/browser/terminalLinkParsing.test.ts#L42}vscode
       terminal link parsing}.*)
  let pp_pos file ppf pos =
    let open Fmlib_parse in
    let line1, col1 = (Position.line pos, Position.column pos) in
    match file with
    | None -> Format.fprintf ppf "%d.%d" line1 col1
    | Some file -> Format.fprintf ppf "%s:%d.%d" file line1 col1

  (** [pp_range file].

      The format conforms to
      {{:https://github.com/microsoft/vscode/blob/d2bd76b5cad77e4d380853533014bc9f94ef0405/src/vs/workbench/contrib/terminalContrib/links/test/browser/terminalLinkParsing.test.ts#L42}vscode
       terminal link parsing}.*)
  let pp_range file ppf (start, end_) =
    let open Fmlib_parse in
    let line1, col1 = (1 + Position.line start, 1 + Position.column start) in
    let line2, col2 = (1 + Position.line end_, 1 + Position.column end_) in
    match file with
    | None -> Format.fprintf ppf "%d.%d-%d.%d" line1 col1 line2 col2
    | Some file when line1 = 0 && col1 = 0 && line2 = 0 && col2 = 0 ->
        Format.pp_print_string ppf file
    | Some file ->
        Format.fprintf ppf "%s:%d.%d-%d.%d" file line1 col1 line2 col2

  (** For error reporting it is nice to display the source filename and the
      source code itself. They are optional. In fact, in situations like partial
      parsing (REPL, auto-completion, etc.) we may not know the full source code
      of a thunk. *)
  module State : sig
    type t = private {
      origin : string option;
          (** The file or URL containing the source contents. *)
      source_contents : string option;
          (** The source contents, if available. This is used for error
              reporting and syntax highlighting. *)
      downgrade_errors_into_warnings : bool;
          (** [true] if and only if all errors should be downgraded to warnings.
              Use when parsing a file that will be skipped if it has problems.
          *)
      allow_deprecated_toplevel_moduleid : bool;
          (** [true] if and only if the deprecated toplevel [module_id] field is
              allowed in values files ["*.values.json"]. *)
      skip_first_n_terms : int;
          (** If > 0, skip the first [n] terms in the input. Useful for REPLs.
          *)
    }
    (** The state of the parser, which includes the source file and the starting
        position. *)

    val create_without_source :
      ?origin:string ->
      ?downgrade_errors_into_warnings:unit ->
      ?allow_deprecated_toplevel_moduleid:unit ->
      ?skip_first_n_terms:int ->
      unit ->
      t

    val create_with_source :
      ?origin:string ->
      ?downgrade_errors_into_warnings:unit ->
      ?allow_deprecated_toplevel_moduleid:unit ->
      ?skip_first_n_terms:int ->
      string ->
      t
    (** [create_with_source ?origin ?downgrade_errors_into_warnings
         source_contents] creates an initial state at the starting position
        (line 1, column 1) of the source contents (ie. JSON if a thunk)
        [source_contents].

        The [origin] should be a human-readable identifier for the source
        contents. A linkable identifier is even better for the end-user to click
        in their favorite IDE. So if the source comes from a file, the [origin]
        should be the file path relative to the project root or an absolute
        path. If the source comes from the Internet/intranet, the [origin]
        should be the URL. If the source comes from a REPL, the [origin] should
        be [None]. *)

    val none : t
    val origin : t -> string option
    val source_contents : t -> string option
    val downgrade_errors_into_warnings : t -> bool
    val allow_deprecated_toplevel_moduleid : t -> bool
    val skip_first_n_terms : t -> int
  end = struct
    type t = {
      origin : string option;
      source_contents : string option;
      downgrade_errors_into_warnings : bool;
      allow_deprecated_toplevel_moduleid : bool;
      skip_first_n_terms : int;
    }

    let create_without_source ?origin ?downgrade_errors_into_warnings
        ?allow_deprecated_toplevel_moduleid ?(skip_first_n_terms = 0) () =
      {
        origin;
        source_contents = None;
        downgrade_errors_into_warnings =
          downgrade_errors_into_warnings = Some ();
        allow_deprecated_toplevel_moduleid =
          allow_deprecated_toplevel_moduleid = Some ();
        skip_first_n_terms;
      }

    let create_with_source ?origin ?downgrade_errors_into_warnings
        ?allow_deprecated_toplevel_moduleid ?(skip_first_n_terms = 0)
        source_contents =
      {
        origin;
        source_contents = Some source_contents;
        downgrade_errors_into_warnings =
          downgrade_errors_into_warnings = Some ();
        allow_deprecated_toplevel_moduleid =
          allow_deprecated_toplevel_moduleid = Some ();
        skip_first_n_terms;
      }

    let none =
      {
        origin = None;
        source_contents = None;
        downgrade_errors_into_warnings = false;
        allow_deprecated_toplevel_moduleid = false;
        skip_first_n_terms = 0;
      }

    let origin { origin; _ } = origin
    let source_contents { source_contents; _ } = source_contents

    let downgrade_errors_into_warnings { downgrade_errors_into_warnings; _ } =
      downgrade_errors_into_warnings

    let allow_deprecated_toplevel_moduleid
        { allow_deprecated_toplevel_moduleid; _ } =
      allow_deprecated_toplevel_moduleid

    let skip_first_n_terms { skip_first_n_terms; _ } = skip_first_n_terms
  end

  (** Semantic errors that have locations and error text. *)
  module Semantic : sig
    type t = private {
      error_range : Fmlib_parse.Position.range;
      error_message : string;
      is_rendered : bool;
    }

    val create : Fmlib_parse.Position.range -> string -> t
    val create_rendered : Fmlib_parse.Position.range -> string -> t
    val pp : Format.formatter -> t -> unit
    val error_range : t -> Fmlib_parse.Position.range
    val error_message : t -> string
    val is_rendered : t -> bool
  end = struct
    type t = {
      error_range : Fmlib_parse.Position.range;
      error_message : string;
      is_rendered : bool;
          (** [true] if the {!error_message} has been rendered with a
              pretty-printer, [false] otherwise. *)
    }

    let pp ppf { error_range; error_message; is_rendered } =
      Format.fprintf ppf "@[<v 2>Error: %s@,%a.@ Rendered: %b@]" error_message
        (pp_range None) error_range is_rendered

    let create error_range error_message =
      { error_range; error_message; is_rendered = false }

    let create_rendered error_range error_message =
      { error_range; error_message; is_rendered = true }

    let error_range { error_range; _ } = error_range
    let error_message { error_message; _ } = error_message
    let is_rendered { is_rendered; _ } = is_rendered
  end

  (** A type of parser that has locations and error text for semantic errors. *)
  module type LOCATED_STRING_SEMANTIC_PARSER = sig
    type t
    type final
    type semantic = Semantic.t
    type expect = string * Fmlib_parse.Indent.expectation option

    val position : t -> Fmlib_parse.Position.t
    val has_succeeded : t -> bool
    val has_failed_semantic : t -> bool
    val has_failed_syntax : t -> bool
    val failed_semantic : t -> semantic
    val failed_expectations : t -> expect list
    val final : t -> final
  end

  let pp_list_of_strings =
    Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)

  let write_pretty_print_to_string (r : Fmlib_pretty.Print.t) : string =
    let open Fmlib_pretty.Print in
    let buf = Buffer.create 100 in
    let rec write r =
      if has_more r then begin
        Buffer.add_char buf (peek r);
        write (advance r)
      end
    in
    write r;
    Buffer.contents buf

  let string_find (f : char -> bool) (i : int) (s : string) : int =
    let l = String.length s in
    let rec loop i =
      if i >= l then l else if f s.[i] then i else loop (i + 1)
    in
    loop i

  (** Like {!Fmlib_pretty.Print.wrap_words} but breaks at line endings rather
      than word endings. *)
  let wrap_pretty_print_lines (s : string) : Fmlib_pretty.Print.doc =
    let open Fmlib_pretty.Print in
    let is_newline c = c = '\n' || c = '\r' in
    let not_newline c = not (is_newline c) in
    let line_start i = string_find not_newline i s
    and line_end i = string_find is_newline i s
    and len = String.length s in
    let rec from i () =
      assert (i < len && not_newline s.[i]);
      let j = line_end i in
      let k = line_start j in
      assert (i < j);
      assert (j = len || is_newline s.[j]);
      assert (k = len || not_newline s.[k]);
      (* A cryptic comment in [Fmlib_pretty.Print.paragraphs] says:
         > The function works best if each paragraph ends in a newline.

         So we add the newline (<+> char '\n') except at end of document.

         But that produces extra newlines when [<+> group space], so
         disable the group space.

         With just the group space, we sometimes get space breaks rather
         than line breaks, and that messes up the layout of nested
         semantic errors where the source code has to be lined up with
         the error. *)
      let d = substring s i (j - i) in
      if k = len then (* only newlines after [d] *)
        d
      else d <+> char '\n' (* <+> group space *) >> from k
    in
    let i = line_start 0 in
    if i = len then empty else from i ()

  module type OBSERVER_RESULT = sig
    type t

    val create_report : ?code:string -> ?is_error:bool -> unit -> t
    val with_message : string -> t -> t

    val add_marker :
      marker_message:string ->
      origin:string option ->
      range:Fmlib_parse.Position.range ->
      t ->
      t

    val add_expectation : label:string -> string -> t -> t
    val add_note : string -> t -> t
    val add_hint : string -> t -> t
    val render : origin:string option -> source:string -> t -> string

    module Make : functor (P : LOCATED_STRING_SEMANTIC_PARSER) -> sig
      val observe :
        cant_do:string ->
        source:string ->
        State.t ->
        P.t ->
        (P.final, Semantic.t) result
      (** [observe ~cant_do ~source state parser].

          [cant_do] should say what couldn't be done if an error occurred. It
          must be in ["VERB NOUN"] form like ["create database"] where the
          ["Could not"] start of sentence is implicit. *)
    end
  end

  (** A quick way to report a single error. *)
  let single_error ~code ~msg ~brief_instruction
      (module ResultObserver : OBSERVER_RESULT) sourcestate rangeplus =
    let ro = ResultObserver.create_report ~code ~is_error:true () in
    let origin = State.origin sourcestate in
    let ro = ResultObserver.with_message msg ro in
    let ro =
      ResultObserver.add_marker ~marker_message:brief_instruction ~origin
        ~range:(ThunkLexers.Ranges.display_range rangeplus)
        ro
    in
    match State.source_contents sourcestate with
    | None -> msg
    | Some source -> ResultObserver.render ~origin ~source ro

  (** An observe result that uses the fmlib_parser [Error_reporter] library for
      errors. It can do layout but not print in color. *)
  module MakeObserverWithErrorReporter : OBSERVER_RESULT = struct
    type marker = {
      message : string;
      origin : string option;
      range : Fmlib_parse.Position.range;
    }

    type expectation = { label : string; explanation : string }
    type blurb = Expectation of expectation | Hint of string | Note of string

    type t = {
      code : string option;
      message : string option;
      markers : marker list;
      blurbs : blurb list;
      is_error : bool;
    }

    let doc_of_range ~origin (locrange : Fmlib_parse.Position.range option) :
        Fmlib_pretty.Print.doc =
      let open Fmlib_pretty.Print in
      match (locrange, origin) with
      | None, None -> empty
      | None, Some origin -> text "In " <+> text origin <+> text ":"
      | Some locrange, _ ->
          text "In "
          <+> text (Format.asprintf "%a" (pp_range origin) locrange)
          <+> text ":" <+> space

    let pretty_print_to_string ~origin
        (locrange : Fmlib_parse.Position.range option)
        (doc : Fmlib_pretty.Print.doc) : string =
      let open Fmlib_pretty.Print in
      let firstline = doc_of_range ~origin locrange in
      (* assert (Stringext.find_from rest ~pattern:"Expected an MlFront library" = None); *)
      write_pretty_print_to_string
      @@ Fmlib_pretty.Print.layout 70 (group (firstline <+> doc))

    let create_report ?code ?(is_error = true) () =
      { code; message = None; markers = []; blurbs = []; is_error }

    let with_message message t = { t with message = Some message }

    let add_marker ~marker_message ~origin ~range t =
      let marker = { message = marker_message; origin; range } in
      { t with markers = marker :: t.markers }

    let add_expectation ~label explanation t =
      let expectation = { label; explanation } in
      { t with blurbs = Expectation expectation :: t.blurbs }

    let add_hint hint t = { t with blurbs = Hint hint :: t.blurbs }
    let add_note note t = { t with blurbs = Note note :: t.blurbs }

    let render ~origin ~source { code; message; markers; blurbs; is_error } =
      let open Fmlib_pretty.Print in
      let wrap_lines s =
        Stringext.split ~on:'\n' s
        |> List.map (fun line -> text line)
        |> paragraphs
      in
      let with_idx l = List.mapi (fun i x -> (i, x)) l in
      let doc =
        fill 20 '-'
        <+> text (if is_error then " FATAL ERROR " else " WARNING ")
        <+> fill 20 '-' <+> space
        <+> (match code with
            | None -> empty
            | Some code ->
                text
                  (Printf.sprintf "[%s %s]"
                     (if is_error then "error" else "warning")
                     code)
                <+> space)
        <+> match message with None -> empty | Some m -> wrap_lines m
      in
      let doc = doc <+> space <+> fill 20 '.' in
      (* Either display [source] immediately (when there are no markers) *)
      let doc =
        if markers = [] then doc <+> space <+> wrap_lines source else doc
      in
      (* Or display [source] within the first marker *)
      let doc =
        List.fold_left
          (fun doc (i, { message; origin; range }) ->
            doc <+> space
            <+> doc_of_range ~origin (Some range)
            <+> (if i = 0 then nest 2 (wrap_lines source) <+> space else empty)
            <+> (text "-" <+> space <+> nest 2 (wrap_lines message)))
          doc (with_idx markers)
      in
      let doc =
        (if blurbs <> [] then space else empty)
        <+> List.fold_left
              (fun doc (i, blurb) ->
                doc <+> space
                <+> (if i = 0 then fill 20 '.' <+> space else empty)
                <+>
                match blurb with
                | Expectation { label; explanation } ->
                    text label <+> space
                    <+> group (wrap_words explanation <+> cut)
                | Hint hint ->
                    text "Hint:" <+> space <+> nest 2 (wrap_words hint <+> cut)
                | Note note ->
                    text "Note:" <+> space <+> nest 2 (wrap_words note <+> cut))
              doc (with_idx blurbs)
      in
      pretty_print_to_string ~origin None doc

    module Make (P : LOCATED_STRING_SEMANTIC_PARSER) = struct
      module Reporter = Fmlib_parse.Error_reporter.Make (P)

      let observe ~cant_do ~source sourcestate p : (P.final, Semantic.t) result
          =
        let origin = State.origin sourcestate in
        let cant_do_sentence = Printf.sprintf "Could not %s." cant_do in
        if P.has_succeeded p then Ok (P.final p)
        else if P.has_failed_syntax p then
          (* A syntax error is at one position. *)
          let range = (P.position p, P.position p) in
          Error
            (Semantic.create_rendered range
            @@ Reporter.(
                 make_syntax p |> run_on_string source
                 |> pretty_print_to_string ~origin (Some range)))
        else if P.has_failed_semantic p then
          (* A semantic error is over a location range. *)
          let semantic = P.failed_semantic p in
          let range = Semantic.error_range semantic in
          if Semantic.is_rendered semantic then
            (* If the error has already been rendered, we don't wrap
               and re-render it again. But we do prepend the original
               "can't do" reason since it may have new debugging
               information. And we say "warning" since it is not the root cause;
               in fact it is a more general error. *)
            Error
              (Semantic.create_rendered range
              @@ Printf.sprintf "[warning] %s\n%s" cant_do_sentence
                   (Semantic.error_message semantic))
          else
            Error
              (Semantic.create_rendered range
              @@ Reporter.(
                   make Semantic.error_range
                     (fun semantic' ->
                       wrap_pretty_print_lines
                         (Printf.sprintf "%s\n%s" cant_do_sentence
                            (Semantic.error_message semantic')))
                     p
                   |> run_on_string source
                   |> pretty_print_to_string ~origin (Some range)))
        else
          Error
            (Semantic.create_rendered
               Fmlib_parse.Position.(start, start)
               cant_do_sentence)
    end
  end

  (** An observe result that uses the Haskell [diagnose] library (an OCaml port)
      for errors. It can print in color but doesn't do layout. *)
  module MakeObserverWithDiagnoseErrors
      (AnsiStyle : Diagnose.Diagnose.ANSI_STYLE) : OBSERVER_RESULT = struct
    module Doc = Diagnose.Diagnose.MakeAnnotatedDoc (AnsiStyle)
    module Themes = Diagnose.Diagnose.MakeThemes (AnsiStyle)

    module Report =
      Diagnose.Diagnose.MakeReport (AnsiStyle) (Doc)
        (struct
          let style = Themes.default_style
        end)

    type t = string Report.t

    let create_report ?code ?(is_error = true) () : t =
      {
        markers = [];
        is_error;
        code;
        message = "TODO - fill in message";
        blurbs = [];
      }

    let to_marker msg origin ((start_, end_) : Fmlib_parse.Position.range) :
        Report.position * 'msg Report.marker =
      let pos =
        let open Report in
        {
          file = origin;
          begin_line = 1 + Fmlib_parse.Position.line start_;
          end_line = 1 + Fmlib_parse.Position.line end_;
          begin_col = 1 + Fmlib_parse.Position.column start_;
          end_col = 1 + Fmlib_parse.Position.column end_;
        }
      in
      (pos, This msg)

    let add_marker ~marker_message ~origin ~range (report : t) =
      {
        report with
        markers = to_marker marker_message origin range :: report.markers;
      }

    let with_message message (report : t) = { report with message }

    let add_expectation ~label explanation (report : t) =
      {
        report with
        blurbs = Report.Expectation (label, explanation) :: report.blurbs;
      }

    let add_hint hint (report : t) =
      { report with blurbs = Report.Hint hint :: report.blurbs }

    let add_note note (report : t) =
      { report with blurbs = Report.Note note :: report.blurbs }

    let render ~origin ~source (report : t) : string =
      let readonly_file_map =
        let line_array = String.split_on_char '\n' source |> Array.of_list in
        Diagnose.Diagnose.FilenameMap.add origin line_array
          Diagnose.Diagnose.FilenameMap.empty
      in
      Report.pretty_report ~readonly_file_map ~with_unicode:true ~tab_size:4
        report

    let mk_pretty_report sourcestate source
        (report_transformer : string option -> t -> t) =
      let origin = State.origin sourcestate in
      let downgrade_errors_into_warnings =
        State.downgrade_errors_into_warnings sourcestate
      in
      render ~origin ~source
        (report_transformer origin
           (create_report ~is_error:(not downgrade_errors_into_warnings) ()))

    module Make (P : LOCATED_STRING_SEMANTIC_PARSER) = struct
      let observe ~cant_do ~source sourcestate p : (P.final, Semantic.t) result
          =
        let cant_do_sentence = Printf.sprintf "Could not %s." cant_do in
        if P.has_succeeded p then Ok (P.final p)
        else if P.has_failed_syntax p then
          (* A syntax error is at one position. *)
          let pos = P.position p in
          let pretty_report =
            let failures = P.failed_expectations p in
            mk_pretty_report sourcestate source (fun origin report ->
                let report = with_message "There was a syntax error." report in
                let report =
                  add_marker ~marker_message:"This is invalid syntax." ~origin
                    ~range:(pos, pos) report
                in
                let _i, report =
                  List.fold_left
                    (fun (i, report) (exp, _indent_expectation) ->
                      let report =
                        add_expectation
                          ~label:(if i == 0 then "We expected:" else "or:")
                          exp report
                      in
                      (i + 1, report))
                    (0, report) failures
                in
                report)
          in
          Error (Semantic.create_rendered (pos, pos) pretty_report)
        else if P.has_failed_semantic p then
          (* A semantic error is over a location range. *)
          let semantic = P.failed_semantic p in
          let range = Semantic.error_range semantic in
          if Semantic.is_rendered semantic then
            (* If the error has already been rendered, we don't wrap
               and re-render it again. But we do prepend the original
               "can't do" reason since it may have new debugging
               information. And we say "warning" since it is not the root cause;
               in fact it is a more general error. *)
            Error
              (Semantic.create_rendered range
              @@ Printf.sprintf "[warning] %s\n%s" cant_do_sentence
                   (Semantic.error_message semantic))
          else
            let pretty_report =
              mk_pretty_report sourcestate source (fun origin report ->
                  let report = with_message cant_do_sentence report in
                  let report =
                    add_marker
                      ~marker_message:(Semantic.error_message semantic)
                      ~origin ~range report
                  in
                  report)
            in
            Error (Semantic.create_rendered range pretty_report)
        else
          Error
            (Semantic.create_rendered
               Fmlib_parse.Position.(start, start)
               cant_do_sentence)
    end
  end
end

(** Make a sub-parser for a specific range of the input. Use a sub-parser when
    you have a separate language with a different lexer than the main language,
    but the separate language is embedded inside the main language. *)
module MakeSubparse (PL : sig
  type t

  val needs_more : t -> bool
  val run_on_string_at : int -> string -> t -> int * t
  val put_end : t -> t
end) : sig
  val parse :
    Results.State.t ->
    ThunkLexers.Ranges.range_plus option ->
    PL.t ->
    string ->
    string * PL.t
  (** [parse sourcestate locrange start s] returns a subparser of the underlying
      source code at a start and end position that correspond to the underlying
      source code's range [locrange] {i if} the underlying source is available
      in [sourcestate]; otherwise the subparser will parse the string [s].

      The [locrange] must be accurate. An assertion will be raised if the
      [locrange] would reach out of bounds for the underlying source code or if
      its width exceeds the length of [s]. If you can't provide an accurate
      [locrange] then use [None].

      [start] is the initial parsing state of the subparser. There are two
      technical requirements for the subparser state. Those are described in the
      {!subparserstate} section.

      The return value is the pair [(actual_source, parser)] where
      [actual_source] is the source code used during the subparse and [parser]
      reflects the state of the subparse after processing [actual_source]. Any
      errors captured in [parser] will be reported with correct source locations
      within [actual_source].
      {b Do not use [s] as the source code for error reporting.}

      {2:subparserstate Subparser State}

      {3 Character unescaping and Normalization}

      Be careful to make sure that any escaping or normalization of the string
      [s] that is done by the parent parser is also done in the subparse. For
      example if the parent parser is a JSON parser and the subparser is
      operating on JSON strings, the subparser must ensure that JSON escape
      sequences are recognized. More accurately,
      {b the subparser must use a lexer that unescapes and normalizes as it
         creates tokens during lexing}.

      A good way to accomplish the lexer synchronization between the parent and
      subparser is for the subparser to use a lexer with state; the state would
      have a dedicated field for an externally-supplied character
      normalization/unescaping function. Since technically normalization and
      unescaping are lexers on the [char] or [Uchar.t] character stream that
      create [char] or [Uchar.t] tokens, a first-class module
      {!Fmlib_parse.Interfaces.MINIMAL_PARSER} type is a good choice for the
      externally-supplied character normalization/unescaping function. Then your
      lexer operates on the newly normalized [char] or [Uchar.t] stream to
      create its own tokens.

      {3 Start position}

      The subparser's lexer must start at the position of the first character in
      the [locrange] supplied to the parse function. If you don't do this, you
      will have inaccurate location reporting.

      It is a good practice to add a new function to your lexer:

      {[
        (* Keep the [start] function because Fmlib_parse.Interfaces.LEXER mandates it. *)

        let start : t =
          (* Lexer starting at the start of the input. *)
          C.make_partial Position.start () C.token

        (* But add the [start_at] function *)

        (** [start_at ?pos ()] starts the lexer at the start of the input or at
            specified [pos] if [pos] is supplied. *)
        let start_at ?(pos = Position.start) () : t =
          C.make_partial pos () C.token
      ]}

      That way, before you call the {!parse} function, you can construct the
      [start] subparser value like so:

      {[
        let start =
          Lexer.start_at
            ?pos:(Option.map ThunkLexers.Ranges.start_of_range_plus rangeplus)
            ()
        in
        Subparse.parse ~rangeplus sourcestate rangeplus start s (* ... *)
      ]}

      or if you have a lexer-parser combination with
      {!Parse_with_lexer.Make_utf8} you can do:

      {[
        include
          Parse_with_lexer.Make_utf8 (State) (Token) (Command) (Semantic)
            (Lexer)
            (Parser)

        let start rangeplus : t =
          make
            (Lexer.start_at
               ?pos:
                 (Option.map ThunkLexers.Ranges.start_of_range_plus rangeplus)
               ())
            Parser.parse
      ]}

      Unfortunately the {!Fmlib_parse.Ucharacter.Make_utf8}
      [module U = Fmlib_parse.Ucharacter.Make_utf8 (State) (Final) (Semantic)]
      functor's [U.make] function does not have a parameter to set the start
      position. Instead supply your own [make_at] function like below:

      {[
        module U = struct
          include Fmlib_parse.Ucharacter.Make_utf8 (State) (Final) (Semantic)

          let make_at ?(pos = Fmlib_parse.Position.start) state
              (final : Parser.final t) : Parser.t =
            make_partial pos state (final >>= expect_end)
        end
      ]} *)
end = struct
  let parse
      ({
         origin = _;
         source_contents;
         downgrade_errors_into_warnings = _;
         allow_deprecated_toplevel_moduleid = _;
         skip_first_n_terms = _;
       } :
        Results.State.t) (rangeopt : ThunkLexers.Ranges.range_plus option) start
      string_to_parse : string * PL.t =
    let rec run s i stop_excl p =
      if PL.needs_more p then
        if i >= stop_excl then PL.put_end p
        else
          (* Truncate the string so that [run_on_string_at] does not think
             there are more tokens than there are.

             The error display is still correct since the actual untruncated
             source code is returned this [parse] function. *)
          let s' = String.sub s 0 stop_excl in
          let i, p = PL.run_on_string_at i s' p in
          run s' i stop_excl p
      else p
    in
    (* ALERT: Since it is bad if we get the wrong subparse ... we could
       execute the wrong build command in MlFront_Thunk, for example ... it is
       critical to sprinkle the logic with [assert]s. *)
    match (source_contents, rangeopt) with
    | None, _ | _, None ->
        (* Do an ordinary parse (not a subparse); we have no source. *)
        let p' = run string_to_parse 0 (String.length string_to_parse) start in
        (string_to_parse, p')
    | Some actual_source, Some (Raw_range (startpos, endpos)) ->
        (* Arrange the source so it corresponds to the raw subparse range. *)
        let start_idx_incl = Fmlib_parse.Position.byte_offset startpos in
        let end_idx_excl = String.length string_to_parse + start_idx_incl in
        assert (end_idx_excl <= String.length actual_source);
        assert (end_idx_excl = Fmlib_parse.Position.byte_offset endpos);
        assert (
          String.equal string_to_parse
            (String.sub actual_source start_idx_incl
               (end_idx_excl - start_idx_incl)));
        let p' = run actual_source start_idx_incl end_idx_excl start in
        (actual_source, p')
    | Some actual_source, Some (Mapped_range { inner_range = startpos, endpos })
      ->
        (* Arrange the source so it corresponds to the mapped subparse range. *)
        let start_idx_incl = Fmlib_parse.Position.byte_offset startpos in
        let end_idx_excl = Fmlib_parse.Position.byte_offset endpos in
        assert (end_idx_excl <= String.length actual_source);
        let p' = run actual_source start_idx_incl end_idx_excl start in
        (actual_source, p')
end

(** A parser of {{:https://semver.org/#semantic-versioning-200}semver 2.0.0}
    strings. *)
module SemverParsers = struct
  module Semver64Combinators
      (P :
        ThunkLexers.Characters.UCHAR_PARSER
          with type Parser.semantic = Results.Semantic.t) =
  struct
    open P
    open ThunkLexers.Characters

    (* This is a port of the OCaml [semver] package which uses Angstrom. *)

    let no_leading_zero str = String.length str <= 1 || String.get str 0 != '0'

    let nat : int64 t =
      let* digitsloc, digits =
        backtrack
          (let* digitsloc, (first_digit, rest_digits) =
             one_or_more (ucharp uchar_digit "a digit of a version number")
             |> located
           in
           let str = utf8string_of_uchars (first_digit :: rest_digits) in
           if no_leading_zero str then return (digitsloc, str)
           else
             fail
               (Results.Semantic.create digitsloc
                  "leading zero (0) in version number"))
          "version number"
      in
      match Int64.of_string_opt digits with
      | Some n -> return n
      | None ->
          fail
            (Results.Semantic.create digitsloc
               "64-bit version number [0-9223372036854775807]")

    let base_identifier : string t =
      let* first_uchar, rest_uchars =
        one_or_more
          (ucharp
             (function
               | c when c = uchar_MINUS -> true
               | c when uchar_digit c -> true
               | c when uchar_alpha c -> true
               | _ -> false)
             "identifier character `-`, `A-Z`, `a-z` or `0-9`")
      in
      return (utf8string_of_uchars (first_uchar :: rest_uchars))

    let prerelease_identifier =
      let* baseloc, str = base_identifier |> located in
      match int_of_string_opt str with
      | None -> return str
      | Some _ ->
          if no_leading_zero str then return str
          else
            fail
              (Results.Semantic.create baseloc
                 ("leading 0 in prerelease identifier: " ^ str))

    let identifier_list (id_parser : string t) sep sep_expectation :
        string list t =
      (let* _ = uchar sep <?> sep_expectation in
       one_or_more_separated
         (fun item -> return [ item ])
         (fun acc sep item ->
           ignore sep;
           return (acc @ [ item ]))
         id_parser
         (string "." <?> "separator character `.`"))
      </> return []

    let semver =
      let* major = nat <?> "a major version number" in
      let* _ = uchar uchar_PERIOD in
      let* minor = nat <?> "a minor version number" in
      let* _ = uchar uchar_PERIOD in
      let* patch = nat <?> "a patch version number" in
      let* prerelease =
        identifier_list prerelease_identifier uchar_MINUS
          "`-` to start a prerelease identifier"
      in
      let* build =
        identifier_list base_identifier uchar_PLUS
          "`+` to start a build identifier"
      in
      return { ThunkSemver64Rep.major; minor; patch; prerelease; build }
  end

  module Int64Parser =
    Fmlib_parse.Ucharacter.Make_utf8
      (ThunkLexers.Characters.UcharDecodeState)
      (Int64)
      (Results.Semantic)

  module StringParser =
    Fmlib_parse.Ucharacter.Make_utf8
      (ThunkLexers.Characters.UcharDecodeState)
      (String)
      (Results.Semantic)

  (** A complete parser for natural numbers. *)
  module NatPL = struct
    open Semver64Combinators (Int64Parser)

    let parse state s =
      let start =
        Int64Parser.make_partial Fmlib_parse.Position.start state nat
      in
      let p = Int64Parser.Parser.run_on_string s start in
      let module H =
        Results.MakeObserverWithErrorReporter.Make (Int64Parser.Parser) in
      H.observe ~cant_do:"parse natural number" ~source:s
        (Results.State.create_with_source s)
        p
  end

  (** A complete parser for base identifiers. *)
  module BaseIdentifierPL = struct
    open Semver64Combinators (StringParser)

    let parse state s =
      let start =
        StringParser.make_partial Fmlib_parse.Position.start state
          base_identifier
      in
      let p = StringParser.Parser.run_on_string s start in
      let module H =
        Results.MakeObserverWithErrorReporter.Make (StringParser.Parser) in
      H.observe ~cant_do:"parse base identifier" ~source:s
        (Results.State.create_with_source s)
        p
  end

  (** A complete parser for prerelease identifiers. *)
  module PrereleaseIdentifierPL = struct
    open Semver64Combinators (StringParser)

    let parse state s =
      let start =
        StringParser.make_partial Fmlib_parse.Position.start state
          prerelease_identifier
      in
      let p = StringParser.Parser.run_on_string s start in
      let module H =
        Results.MakeObserverWithErrorReporter.Make (StringParser.Parser) in
      H.observe ~cant_do:"parse prerelease identifier" ~source:s
        (Results.State.create_with_source s)
        p
  end

  (** The complete parser for semver version with 64-bit components. *)
  module MakeSemver64PL
      (P :
        ThunkLexers.Characters.UCHAR_PARSER
          with type Parser.semantic = Results.Semantic.t
           and type Parser.state = ThunkLexers.Characters.UcharDecodeState.t
           and type Parser.final = ThunkSemver64Rep.t) =
  struct
    include P.Parser
    open Semver64Combinators (P)

    let parse = semver

    let start_at rangeplus state =
      let open P in
      make_partial
        (match rangeplus with
        | None -> Fmlib_parse.Position.start
        | Some rangeplus -> ThunkLexers.Ranges.start_of_range_plus rangeplus)
        state
        (let* r = parse in
         expect_end r)

    let start rangeplus = start_at rangeplus `DirectDecode
  end

  module Semver64Parser =
    Fmlib_parse.Ucharacter.Make_utf8
      (ThunkLexers.Characters.UcharDecodeState)
      (ThunkSemver64Rep)
      (Results.Semantic)
  (** The parser receiving unicode characters and parsing a {!ThunkSemver64Rep}
      construct. *)

  module Semver64PL = MakeSemver64PL (Semver64Parser)
end

(** A simplified parser of commands for the POSIX shell.

    The grammar is described in
    {{:https://pubs.opengroup.org/onlinepubs/9799919799/utilities/V3_chap02.html#tag_19_10}IEEE
     Std 1003.1-2024 - 2.10 Shell Grammar}. *)
module PosixShellParsers = struct
  (** Logical representation of a command in the POSIX shell, designed for unit
      tests of the lexer. *)
  module SimpleCommand = struct
    type t = Words of string list

    let words sl = Words sl

    let to_string : t -> string =
      let ocaml_quote s = "\"" ^ String.escaped s ^ "\"" in
      function
      | Words sl -> "[" ^ String.concat "; " (List.map ocaml_quote sl) ^ "]"
  end

  (** The parser receiving lexical tokens and parsing a {!SimpleCommand}
      construct, designed for unit tests of the lexer. *)
  module SimpleParser = struct
    open Fmlib_parse
    open ThunkLexers.PosixShellLexer

    module C = struct
      include
        Token_parser.Make (ThunkLexers.Characters.UcharDecodeState) (Token)
          (SimpleCommand)
          (Results.Semantic)

      let const (a : 'a) (_ : 'b) : 'a = a

      let step (expect : string) (etp : Token.tp) (f : string -> 'a) : 'a t =
        step expect (fun state _ (tp, str) ->
            if tp = etp then Some (f str, state) else None)

      let bareword : string t = step "bareword" Token.BareWord Fun.id

      let singlequotedword : string t =
        step "word" Token.SingleQuotedWord Fun.id

      let doublequotedword : string t =
        step "word" Token.DoubleQuotedWord Fun.id

      let word : string t = bareword </> singlequotedword </> doublequotedword

      let rec command () : SimpleCommand.t t = words ()

      and words () : SimpleCommand.t t =
        let* lst = zero_or_more word in
        return (SimpleCommand.Words lst)
    end

    include C.Parser

    let parse : t = C.(make `DirectDecode (command ()))

    let parse_partial : t =
      C.(
        make_partial `DirectDecode
          (command () </> expect_end (SimpleCommand.Words [])))
  end

  (** The complete parser, designed for unit tests of the lexer. *)
  module SimplePL = struct
    open Fmlib_parse
    open ThunkLexers.PosixShellLexer

    include
      Parse_with_lexer.Make_utf8
        (ThunkLexers.Characters.UcharDecodeState)
        (Token)
        (SimpleCommand)
        (Results.Semantic)
        (Lexer)
        (SimpleParser)

    let start rangeplus : t =
      make
        (Lexer.start_at
           ?pos:(Option.map ThunkLexers.Ranges.start_of_range_plus rangeplus)
           `DirectDecode)
        SimpleParser.parse
  end
end

(** A JSON parser of {!Jsont.json} values. It should parse according to the
    {{:https://ecma-international.org/publications-and-standards/standards/ecma-404/}JSON
     spec ECMA-404}, and also accept C-style ["// single line comments"] and
    ["/* multi-line comments */"].

    There is the conventional ["jsont_bytesrw"] parser, but it does not support
    JSON comments and it is not integrated into the fmlib_parse error reporting.
*)
module JsonParsers = struct
  (** Logical type for a json value. Compatible with jsont representations. *)
  module type JSON = sig
    type t
    type attr

    val null_ : unit -> attr -> t
    val bool_ : bool -> attr -> t
    val number_ : float -> attr -> t
    val string_ : string -> attr -> t
    val array_ : t list -> attr -> t
    val object_ : ((string * attr) * t) list -> attr -> t
    val getattr : t -> attr
  end

  module type ATTR = sig
    type t
    type state

    val attr : state -> ThunkLexers.Ranges.range_plus -> t
  end

  type json_for_fmlib =
    [ `Null of unit * ThunkLexers.Ranges.range_plus
    | `Bool of bool * ThunkLexers.Ranges.range_plus
    | `Number of float * ThunkLexers.Ranges.range_plus
    | `String of string * ThunkLexers.Ranges.range_plus
    | `Array of json_for_fmlib list * ThunkLexers.Ranges.range_plus
    | `Object of
      ((string * ThunkLexers.Ranges.range_plus) * json_for_fmlib) list
      * ThunkLexers.Ranges.range_plus ]

  type yojson_safe_t =
    [ `Assoc of (string * yojson_safe_t) list
    | `Bool of bool
    | `Float of float
    | `Int of int
    | `Intlit of string
    | `List of yojson_safe_t list
    | `Null
    | `String of string ]

  let json_for_fmlib_to_yojson : json_for_fmlib -> yojson_safe_t =
    let rec aux : json_for_fmlib -> yojson_safe_t = function
      | `Null _ -> `Null
      | `Bool (b, _) -> `Bool b
      | `Number (n, _) -> `Float n
      | `String (s, _) -> `String s
      | `Array (l, _) -> `List (List.map aux l)
      | `Object (l, _) ->
          let l' = List.map (fun ((k, _), v) -> (k, aux v)) l in
          `Assoc l'
    in
    aux

  open struct
    let zerorangeplus =
      ThunkLexers.Ranges.Raw_range Fmlib_parse.Position.(start, start)

    let escape_json_string s =
      let ob = Buffer.create 10 in
      YojsonI.write_string ob s;
      Buffer.contents ob
  end

  let pp_json_for_fmlib ppf j =
    let rec aux = function
      | `Null _ -> Format.fprintf ppf "null"
      | `Bool (b, _) -> Format.pp_print_bool ppf b
      | `Number (n, _) -> Format.pp_print_float ppf n
      | `String (s, _) -> Format.pp_print_string ppf (escape_json_string s)
      | `Array (l, _) ->
          Format.fprintf ppf "[";
          List.iteri
            (fun i j ->
              if i > 0 then Format.fprintf ppf "; ";
              aux j)
            l;
          Format.fprintf ppf "]"
      | `Object (l, _) ->
          Format.fprintf ppf "{";
          List.iteri
            (fun i ((k, _), v) ->
              if i > 0 then Format.fprintf ppf "; ";
              aux (`String (k, zerorangeplus));
              Format.pp_print_string ppf ": ";
              aux v)
            l;
          Format.fprintf ppf "}"
    in
    aux j

  (** A logical representation of a json value with fmlib location atttributes.
  *)
  module JsonForFmlib :
    JSON
      with type attr = ThunkLexers.Ranges.range_plus
       and type t = json_for_fmlib = struct
    type attr = ThunkLexers.Ranges.range_plus
    type t = json_for_fmlib

    let null_ v a = `Null (v, a)
    let bool_ v a = `Bool (v, a)
    let number_ v a = `Number (v, a)
    let string_ v a = `String (v, a)
    let array_ v a = `Array (v, a)
    let object_ v a = `Object (v, a)

    let getattr : t -> attr = function
      | `Null (_, a) -> a
      | `Bool (_, a) -> a
      | `Number (_, a) -> a
      | `String (_, a) -> a
      | `Array (_, a) -> a
      | `Object (_, a) -> a
  end

  module AttrForFmlib :
    ATTR
      with type t = ThunkLexers.Ranges.range_plus
       and type state = Results.State.t = struct
    type t = ThunkLexers.Ranges.range_plus
    type state = Results.State.t

    let attr state range =
      ignore state;
      range
  end

  (** [Parser] is a generic parser receiving lexical JSON tokens and parsing a
      json construct.

      Implemented as a [Token_parser] which can be used by the module
      [Parse_with_lexer] to generate the final parser. *)
  module Parser = struct
    open ThunkLexers.JsonLexer

    module type CJSON = sig
      type 'a t
      type json
      type attr

      val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
      val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
      val map : ('a -> 'b) -> 'a t -> 'b t

      val map_and_update :
        (Results.State.t -> 'a -> 'b * Results.State.t) -> 'a t -> 'b t

      val succeed : 'a -> 'a t
      val return : 'a -> 'a t
      val unexpected : string -> 'a t
      val clear_last_expectation : 'a -> 'a t
      val fail : Results.Semantic.t -> 'a t
      val ( </> ) : 'a t -> 'a t -> 'a t
      val choices : 'a t -> 'a t list -> 'a t
      val ( <?> ) : 'a t -> string -> 'a t
      val no_expectations : 'a t -> 'a t
      val get : Results.State.t t
      val set : Results.State.t -> unit t
      val update : (Results.State.t -> Results.State.t) -> unit t

      val get_and_update :
        (Results.State.t -> Results.State.t) -> Results.State.t t

      val state_around :
        (Results.State.t -> Results.State.t) ->
        'a t ->
        (Results.State.t -> 'a -> Results.State.t -> Results.State.t) ->
        'a t

      val optional : 'a t -> 'a option t
      val zero_or_more_fold_left : 'r -> ('r -> 'a -> 'r t) -> 'a t -> 'r t

      val one_or_more_fold_left :
        ('a -> 'r t) -> ('r -> 'a -> 'r t) -> 'a t -> 'r t

      val zero_or_more : 'a t -> 'a list t
      val one_or_more : 'a t -> ('a * 'a list) t
      val skip_zero_or_more : 'a t -> int t
      val skip_one_or_more : 'a t -> int t

      val one_or_more_separated :
        ('item -> 'r t) ->
        ('r -> 'sep -> 'item -> 'r t) ->
        'item t ->
        'sep t ->
        'r t

      val counted : int -> int -> 'r -> (int -> 'e -> 'r -> 'r) -> 'e t -> 'r t

      val parenthesized :
        ('lpar -> 'a -> 'rpar -> 'b t) ->
        'lpar t ->
        (unit -> 'a t) ->
        ('lpar -> 'rpar t) ->
        'b t

      val operator_expression :
        'exp t ->
        'op t option ->
        'op t ->
        ('op -> 'op -> bool t) ->
        ('op -> 'exp -> 'exp t) ->
        ('exp -> 'op -> 'exp -> 'exp t) ->
        'exp t

      val backtrack : 'a t -> string -> 'a t
      val followed_by : 'a t -> string -> 'a t
      val not_followed_by : 'a t -> string -> unit t
      val expect_end : 'a -> 'a t
      val located : 'a t -> (Fmlib_parse.Position.range * 'a) t
      val indent : int -> 'a t -> 'a t
      val align : 'a t -> 'a t
      val left_align : 'a t -> 'a t
      val detach : 'a t -> 'a t

      (* val make : Results.State.t -> final t -> Parser.t
         val make_partial : Results.State.t -> final t -> Parser.t *)
      (* val const : 'a -> 'b -> 'a *)
      (* val step : string -> Token.tp -> (string -> 'a) -> 'a t *)
      val zero_or_more_separated : 'a t -> 'b t -> 'a list t

      (* val plainstring : string t *)
      val lbrace : string t
      val rbrace : string t
      val lbrack : string t
      val rbrack : string t
      val colon : string t
      val comma : string t
      val null_ : json t
      val true_ : json t
      val false_ : json t
      val number_ : json t
      val string_ : json t
      val json : unit -> json t
      val object_ : unit -> json t
      val key_value_pair : unit -> ((string * attr) * json) t
      val array_ : unit -> json t
      val cast_null : json -> unit t
      val cast_bool : json -> bool t
      val cast_number : json -> float t
      val cast_string : json -> string t
      val cast_array : json -> json list t
      val cast_object : json -> ((string * attr) * json) list t
      val cast_generic_field : (json -> 'a t) -> string -> json -> (attr * 'a) t
      val cast_string_field : string -> json -> (attr * string) t
      val is_object : json -> bool
      val attr : json -> attr t
      val cast_attr_generic : (json -> 'a t) -> json -> (attr * 'a) t
      val cast_attr_string : json -> (attr * string) t
      val pair_attr : json -> (attr * json) t
      val getmember : string -> json -> json t
      val getmemberwithjson : string -> json -> (attr * json) t
      val getmember_opt : string -> json -> json option t
      val getmemberwithjson_opt : string -> json -> (attr * json) option t
      val if_some : 'a option -> ('a -> 'b t) -> 'b option t
      val if_some_snd : ('a * 'b) option -> ('b -> 'c t) -> ('a * 'c) option t
      val for_all : 'a list -> ('a -> 'b t) -> 'b list t
      val for_all_snd : ('a * 'b) list -> ('b -> 'c t) -> ('a * 'c) list t

      val for_all_members :
        (string -> attr -> json -> 'a t) -> json -> 'a list t

      val fst_f_snd : 'a * 'b -> ('b -> 'c t) -> ('a * 'c) t
      val fst_opt : ('a * 'b) option -> 'a option
      val snd_opt : ('a * 'b) option -> 'b option
      val safe_int_of_float : float -> int option
      val safe_int64_of_float : float -> int64 option
      val cast_version_number_int : json -> int t
      val cast_version_number_int64 : json -> int64 t
      val cast_int64 : json -> int64 t
    end

    (** Parsers for the logical representation of JSON *)

    module MakeCJson
        (Final : Fmlib_std.Interfaces.ANY)
        (Attr : ATTR with type state = Results.State.t)
        (J : JSON with type attr = Attr.t) =
    struct
      type attr = Attr.t
      type json = J.t
      type final = Final.t

      include
        Fmlib_parse.Token_parser.Make (Results.State) (Token) (Final)
          (Results.Semantic)

      let const (a : 'a) (_ : 'b) (_ : 'c) : 'a = a

      let step (expect : string) (etp : Token.tp) (f : string -> 'b -> 'a) :
          'a t =
        step expect (fun state _ { tp; value = str; mapped_uchar_lexer } ->
            if tp = etp then Some (f str mapped_uchar_lexer, state) else None)

      let zero_or_more_separated (p : 'a t) (sep : 'b t) : 'a list t =
        map List.rev
          (one_or_more_separated
             (fun x -> return [ x ])
             (fun lst _ x -> return (x :: lst))
             p sep)
        </> return []

      let plainstring =
        step "string" Token.String (fun value mapped_uchar_lexer ->
            match mapped_uchar_lexer with
            | None -> assert false
            | Some { inner_range } -> (value, inner_range))

      let lbrace : _ t = step {|"{"|} Token.Lbrace (const "")
      let rbrace : _ t = step {|"}"|} Token.Rbrace (const "")
      let lbrack : _ t = step {|"["|} Token.Lbrack (const "")
      let rbrack : _ t = step {|"]"|} Token.Rbrack (const "")
      let colon : _ t = step {|":"|} Token.Colon (const "")
      let comma : _ t = step {|","|} Token.Comma (const "")

      let null_ : J.t t =
        let* range, () = step "null" Token.Null (const ()) |> located in
        let* state = get in
        return (J.null_ () (Attr.attr state (Raw_range range)))

      let true_ : J.t t =
        let* range, (_ : bool) =
          step "true" Token.True (const true) |> located
        in
        let* state = get in
        return (J.bool_ true (Attr.attr state (Raw_range range)))

      let false_ : J.t t =
        let* range, (_ : bool) =
          step "false" Token.False (const false) |> located
        in
        let* state = get in
        return (J.bool_ false (Attr.attr state (Raw_range range)))

      let number_ : J.t t =
        let* range, r =
          step "number" Token.Number (fun s _mapped_uchar_lexer ->
              match float_of_string_opt s with
              | None -> None
              | Some flt -> Some flt)
          |> located
        in
        match r with
        | None ->
            fail
              (Results.Semantic.create range
                 "The number cannot be represented in OCaml.")
        | Some r ->
            let* state = get in
            return (J.number_ r (Attr.attr state (Raw_range range)))

      let string_ : J.t t =
        let* r, inner_range = plainstring in
        let* state = get in
        return (J.string_ r (Attr.attr state (Mapped_range { inner_range })))

      let rec json () : J.t t =
        null_ </> true_ </> false_ </> number_ </> string_
        </> (object_ () <?> "{ \"<key>\": <value>, ... }")
        </> (array_ () <?> "[ <value>, ... ]")

      and object_ () : J.t t =
        let* range1, _ = lbrace |> located in
        let* (pairs : ((string * Attr.t) * J.t) list) =
          zero_or_more_separated
            (key_value_pair () <?> "\"<key>\": <value>")
            comma
        in
        let* range2, _ = rbrace |> located in
        let range = Fmlib_parse.Position.merge range1 range2 in
        let* state = get in
        return J.(object_ pairs (Attr.attr state (Raw_range range)))

      and key_value_pair () : ((string * Attr.t) * J.t) t =
        let* key, key_innerrange = plainstring in
        let* _ = colon in
        let* value = json () in
        let* state = get in
        return
          ( ( key,
              Attr.attr state (Mapped_range { inner_range = key_innerrange }) ),
            value )

      and array_ () : J.t t =
        let* range1, _ = lbrack |> located in
        let* (lst : J.t list) = zero_or_more_separated (json ()) comma in
        let* range2, _ = rbrack |> located in
        let range = Fmlib_parse.Position.merge range1 range2 in
        let* state = get in
        return (J.array_ lst (Attr.attr state (Raw_range range)))

      (** {1 Utilities} *)

      let displayattr = ThunkLexers.Ranges.display_range

      let failattr attr msg =
        fail (Results.Semantic.create (displayattr attr) msg)

      let failattrofjson j msg =
        fail
          (Results.Semantic.create (displayattr (JsonForFmlib.getattr j)) msg)

      let cast_null : JsonForFmlib.t -> unit t = function
        | `Null _ -> return ()
        | j -> failattrofjson j "Expected a `null`."
      [@@warning "-unused-value-declaration"]

      let cast_bool : JsonForFmlib.t -> bool t = function
        | `Bool (b, _) -> return b
        | j -> failattrofjson j "Expected a `true` or `false`."

      let cast_number : JsonForFmlib.t -> float t = function
        | `Number (n, _) -> return n
        | j -> failattrofjson j "Expected a number."
      [@@warning "-unused-value-declaration"]

      let cast_string : JsonForFmlib.t -> string t = function
        | `String (s, _) -> return s
        | j -> failattrofjson j "Expected a string."

      let cast_array : JsonForFmlib.t -> JsonForFmlib.t list t = function
        | `Array (a, _) -> return a
        | j -> failattrofjson j "Expected a JSON array."

      let cast_object : JsonForFmlib.t -> ((string * _) * JsonForFmlib.t) list t
          = function
        | `Object (b, _) -> return b
        | j -> failattrofjson j "Expected a JSON object."

      let is_object : JsonForFmlib.t -> bool = function
        | `Object _ -> true
        | _ -> false

      let attr : JsonForFmlib.t -> JsonForFmlib.attr t =
       fun j -> return (JsonForFmlib.getattr j)

      let cast_attr_generic g j =
        let* s = g j in
        let* a = attr j in
        return (a, s)

      let cast_attr_string j = cast_attr_generic cast_string j

      let pair_attr : JsonForFmlib.t -> (_ * JsonForFmlib.t) t =
       fun j ->
        let attr = JsonForFmlib.getattr j in
        return (attr, j)

      let getmemberwithjson : string -> JsonForFmlib.t -> (_ * JsonForFmlib.t) t
          =
       fun fieldname j ->
        let* obj = cast_object j in
        let found =
          List.find_map
            (fun ((fieldname', nameattr), value) ->
              if String.equal fieldname fieldname' then Some (nameattr, value)
              else None)
            obj
        in
        match found with
        | Some (nameattr, value) -> return (nameattr, value)
        | None ->
            failattrofjson j
            @@ Printf.sprintf "Expected the field `%s`." fieldname

      let getmember fieldname j = getmemberwithjson fieldname j |> map snd

      (** [getmemberwithjson_opt field json] gets the field [field] from the
          json [json].

          If the json is not an object, fails.

          If the field does not exist, returns [None].

          In contrast to [optional (getmember field json)] the [getmember_opt]
          function will emit a semantic failure if the json value is not a json
          object. *)
      let getmemberwithjson_opt :
          string -> JsonForFmlib.t -> (_ * JsonForFmlib.t) option t =
       fun name j ->
        let* obj = cast_object j in
        let found =
          List.find_map
            (fun ((name', nameattr), value) ->
              if String.equal name name' then Some (nameattr, value) else None)
            obj
        in
        match found with
        | Some (nameattr, value) -> return (Some (nameattr, value))
        | None -> return None

      let getmember_opt fieldname j =
        getmemberwithjson_opt fieldname j |> map (Option.map snd)

      let cast_generic_field g fieldname j =
        let* fieldvalue = getmember fieldname j in
        let* range, _ = pair_attr fieldvalue in
        let* fieldvaluestring = g fieldvalue in
        return (range, fieldvaluestring)

      let cast_string_field fieldname j =
        cast_generic_field cast_string fieldname j

      let if_some opt f =
        match opt with
        | None -> return None
        | Some u ->
            let* v = f u in
            return (Some v)

      let if_some_snd opt f =
        match opt with
        | None -> return None
        | Some (first, second) ->
            let* v = f second in
            return (Some (first, v))

      let for_all lst f =
        List.fold_right
          (fun x acc_t ->
            let* acc = acc_t in
            let* v = f x in
            return (v :: acc))
          lst (return [])

      let for_all_snd lst f =
        List.fold_right
          (fun x acc_t ->
            let* acc = acc_t in
            let* v = f (snd x) in
            return ((fst x, v) :: acc))
          lst (return [])

      let for_all_members f j =
        let* obj = cast_object j in
        List.fold_right
          (fun ((fieldname, nameattr), value) acc ->
            let* acc = acc in
            let* item = f fieldname nameattr value in
            return (item :: acc))
          obj (return [])

      let fst_f_snd (first, second) f =
        let* second = f second in
        return (first, second)

      let fst_opt = function
        | None -> None
        | Some (first, _second) -> Some first

      let snd_opt = function
        | None -> None
        | Some (_first, second) -> Some second

      let safe_int_of_float (f : float) : int option =
        if classify_float f = FP_nan then None
        else if f >= Int.(to_float max_int) then None
        else if f <= Int.(to_float min_int) then None
        else Some (Int.of_float f)

      let safe_int64_of_float (f : float) : Int64.t option =
        if classify_float f = FP_nan then None
        else if f >= Int64.(to_float max_int) then None
        else if f <= Int64.(to_float min_int) then None
        else Some (Int64.of_float f)

      let cast_version_number_int : JsonForFmlib.t -> int t = function
        | `Number (n, attr) -> begin
            match safe_int_of_float n with
            | None ->
                failattr attr "Expected an integer version number like 12345."
            | Some i when i >= 0 -> return i
            | Some _ ->
                failattr attr
                  "Expected a non-negative integer version number like 12345."
          end
        | j ->
            failattrofjson j
              "Expected a non-negative version number like 12345."

      let cast_version_number_int64 : JsonForFmlib.t -> int64 t = function
        | `Number (n, attr) -> begin
            match safe_int64_of_float n with
            | None ->
                failattr attr
                  "Expected a 64-bit integer version number like 12345."
            | Some i when i >= 0L -> return i
            | Some _ ->
                failattr attr
                  "Expected a non-negative 64-bit integer version number like \
                   12345."
          end
        | j ->
            failattrofjson j
              "Expected a non-negative version number like 12345."

      let cast_int64 : JsonForFmlib.t -> int64 t = function
        | `Number (n, attr) -> begin
            match safe_int64_of_float n with
            | None -> failattr attr "Expected a 64-bit integer like 12345."
            | Some i -> return i
          end
        | j -> failattrofjson j "Expected a 64-bit integer like 12345."
    end

    module _ : CJSON = MakeCJson (String) (AttrForFmlib) (JsonForFmlib)
    (** Validates that MakeCJson is, for some attribute and JSON paramters, of
        module type CJSON. *)
  end

  (** A parser whose final value is {!JsonForFmlib.t}. You can use
      {!json_for_fmlib_to_yojson} to convert the parsed value to a [Yojson.t]
      compatible JSON value. *)
  module JsonParser = struct
    open Fmlib_parse
    open ThunkLexers.JsonLexer

    module Parse = struct
      module CJson =
        Parser.MakeCJson (JsonForFmlib) (AttrForFmlib) (JsonForFmlib)

      include CJson.Parser
      (** Include parsing functions to get the final value, etc. *)

      let parse sourcestate : t = CJson.make sourcestate (CJson.json ())
    end

    include
      Parse_with_lexer.Make_utf8 (Results.State) (Token) (JsonForFmlib)
        (Results.Semantic)
        (Lexer)
        (Parse)

    let start sourcestate rangeplus : t =
      make
        (Lexer.start_at
           ?pos:(Option.map ThunkLexers.Ranges.start_of_range_plus rangeplus)
           ())
        (Parse.parse sourcestate)
  end
end