Source file ThunkResults.ml

(** 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. *)
    deny_deprecated_function_args : bool;
        (** [true] if and only if the function [args] 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 ->
    ?deny_deprecated_function_args:unit ->
    ?skip_first_n_terms:int ->
    unit ->
    t

  val create_with_source :
    ?origin:string ->
    ?downgrade_errors_into_warnings:unit ->
    ?deny_deprecated_function_args: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 deny_deprecated_function_args : t -> bool
  val skip_first_n_terms : t -> int

  val resolve_range_of_source :
    default:string -> t -> ThunkRanges.t option -> string * ThunkRanges.t
  (** [resolve_range_of_source ~default state range] returns the source that
      corresponds to the [range].

      The use cases are:
      - display the source code at [range] with its surrounding context if
        possible; otherwise, display [default].
      - parse the source code at [range] if possible so that error locations
        correspond to the underlying source code; otherwise, parse [default] and
        get error locations that correspond to [default].

      The returned string for display, if the [range] is mapped, may be
      different from [default] since it may include the original, unescaped
      characters. That is by design since the original source code, if
      available, is likely the most useful for the end-user.

      When the [range] is [Some _] and the {!source_contents} are available and
      [default] is the text in the corresponding range of {!source_contents}
      (with one exception), then the returned string is the {!source_contents}
      and the returned range is [range]. The [default] text is not compared to
      the contents of {!source_contents} when the [range] is a mapped range
      because the mapping may have changed the text by adding escape characters.

      Otherwise, the returned string is [default] and the returned range is the
      full range of [default]. *)
end = struct
  type t = {
    origin : string option;
    source_contents : string option;
    downgrade_errors_into_warnings : bool;
    deny_deprecated_function_args : bool;
    skip_first_n_terms : int;
  }

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

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

  let none =
    {
      origin = None;
      source_contents = None;
      downgrade_errors_into_warnings = false;
      deny_deprecated_function_args = 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 deny_deprecated_function_args { deny_deprecated_function_args; _ } =
    deny_deprecated_function_args

  let skip_first_n_terms { skip_first_n_terms; _ } = skip_first_n_terms

  let resolve_range_of_source ~default { source_contents; _ } rangeopt =
    match (source_contents, (rangeopt : ThunkRanges.t option)) with
    | None, _ | _, None ->
        (* We have no source. *)
        (default, ThunkRanges.raw_range_of_string default)
    | Some actual_source, Some (Raw_range (startpos, endpos) as range) ->
        (* Arrange the source so it corresponds to the range. *)
        let start_idx_incl = Fmlib_parse.Position.byte_offset startpos in
        let end_idx_excl = String.length default + start_idx_incl in
        if
          end_idx_excl <= String.length actual_source
          && end_idx_excl = Fmlib_parse.Position.byte_offset endpos
          && String.equal default
               (String.sub actual_source start_idx_incl
                  (end_idx_excl - start_idx_incl))
        then (actual_source, range)
        else (default, ThunkRanges.raw_range_of_string default)
    | ( Some actual_source,
        Some
          (Mapped_range { outer_range = _; inner_range = _, endpos } as range) )
      ->
        (* Arrange the source so it corresponds to the mapped range.
           There is no guarantee that the mapped range does not have
           escape characters so we can't check to see if the raw characters
           in the mapped range equal [default]. *)
        let end_idx_excl = Fmlib_parse.Position.byte_offset endpos in
        if end_idx_excl <= String.length actual_source then
          (actual_source, range)
        else (default, ThunkRanges.raw_range_of_string default)
end

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

  val create : Fmlib_parse.Position.range -> string -> t

  val create_rendered :
    brief:string -> Fmlib_parse.Position.range -> string -> t

  val pp : Format.formatter -> t -> unit
  val pp_message : Format.formatter -> t -> unit
  val error_range : t -> Fmlib_parse.Position.range
  val error_message : t -> string
  val error_brief : t -> string
  val is_rendered : t -> bool

  val prepend_message : t -> string -> t
  (** [prepend_message t prefix] prepends [prefix] to the error message of [t].
      You are responsible for adding newlines if needed. *)
end = struct
  type t = {
    error_range : Fmlib_parse.Position.range;
    error_message : string;
    error_brief : string;
    is_rendered : bool;
        (** [true] if the {!error_message} has been rendered with a
            pretty-printer, [false] otherwise. *)
  }

  let fmt_words ppf s =
    Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
      ppf
      (String.split_on_char '\n' s)

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

  let pp_message ppf { error_message; _ } =
    Format.fprintf ppf "@[<v>%a@]" fmt_words error_message

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

  let create_rendered ~brief error_range error_message =
    { error_range; error_brief = brief; error_message; is_rendered = true }

  let prepend_message t prefix =
    { t with error_message = prefix ^ t.error_message }

  let error_range { error_range; _ } = error_range
  let error_message { error_message; _ } = error_message
  let error_brief { error_brief; _ } = error_brief
  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

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 origin = State.origin sourcestate in
  let is_error = not (State.downgrade_errors_into_warnings sourcestate) in
  let ro = ResultObserver.create_report ~code ~is_error () in
  let ro = ResultObserver.with_message msg ro in
  let ro =
    ResultObserver.add_marker ~marker_message:brief_instruction ~origin
      ~range:(ThunkRanges.inner_range rangeplus)
      ro
  in
  match State.source_contents sourcestate with
  | None -> msg
  | Some source -> ResultObserver.render ~origin ~source ro

open struct
  let brief_syntax ~cant_do_sentence ~failed_expectations () =
    match failed_expectations with
    | [] -> cant_do_sentence
    | [ single ] ->
        Printf.sprintf "%s Expected: %s" cant_do_sentence (fst single)
    | _ ->
        Printf.sprintf "%s Expected one of:\n%s" cant_do_sentence
          (String.concat "\n"
             (List.map (function s, _ -> "- " ^ s) failed_expectations))

  let brief_semantic ~cant_do_sentence ~failed_semantic () =
    cant_do_sentence ^ "\n" ^ Semantic.error_brief failed_semantic
end

(** 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;
  }

  module DocCombinators (Doc : sig
    type doc

    val empty : doc
    val text : string -> doc
    val space : doc
    val substring : string -> int -> int -> doc
    val char : char -> doc
    val ( <+> ) : doc -> doc -> doc
    val ( >> ) : doc -> (unit -> doc) -> doc
  end) =
  struct
    let doc_of_range ~origin (locrange : Fmlib_parse.Position.range option) :
        Doc.doc =
      let open Doc in
      match (locrange, origin) with
      | None, None -> empty
      | None, Some origin -> text "In " <+> text origin <+> text ":"
      | Some locrange, _ ->
          text "In "
          <+> text (Format.asprintf "%a" (ThunkRanges.pp_range origin) locrange)
          <+> text ":" <+> space

    (** Like {!Fmlib_pretty.Print.wrap_words} but breaks at line endings rather
        than word endings. *)
    let wrap_pretty_print_lines (s : string) : Doc.doc =
      let open Doc 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 ()
  end

  module PrintCombinators = DocCombinators (Fmlib_pretty.Print)

  module PrettyCombinators = DocCombinators (struct
    include Fmlib_pretty.Pretty

    type doc = t

    let ( >> ) (m : t) (f : unit -> t) : t = m <+> f ()
  end)

  let doc_to_string ~origin (locrange : Fmlib_parse.Position.range option)
      (doc : Fmlib_pretty.Print.doc) : string =
    let open Fmlib_pretty.Print in
    let firstline = PrintCombinators.doc_of_range ~origin locrange in
    write_pretty_print_to_string
    @@ Fmlib_pretty.Print.layout 70 (group (firstline <+> doc))

  let pretty_to_string ~origin (locrange : Fmlib_parse.Position.range option)
      (pretty : Fmlib_pretty.Pretty.t) : string =
    let open Fmlib_pretty.Pretty in
    let firstline = PrettyCombinators.doc_of_range ~origin locrange in
    Fmlib_pretty.Pretty.to_string
      (Fmlib_pretty.Pretty.layout 70 (group (firstline <+> pretty)))

  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
          <+> PrintCombinators.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
    let rendered = doc_to_string ~origin None doc in
    ThunkStrings.trim_lines_right rendered

  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
             ~brief:
               (brief_syntax ~cant_do_sentence
                  ~failed_expectations:(P.failed_expectations p) ())
             range
          @@ Reporter.(
               make_syntax p |> run_on_string source
               |> pretty_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
               ~brief:(Semantic.error_brief semantic)
               range
            @@ Printf.sprintf "[warning] %s\n%s" cant_do_sentence
                 (Semantic.error_message semantic))
        else
          Error
            (Semantic.create_rendered
               ~brief:
                 (brief_semantic ~cant_do_sentence ~failed_semantic:semantic ())
               range
            @@ Reporter.(
                 make Semantic.error_range
                   (fun semantic' ->
                     PrettyCombinators.wrap_pretty_print_lines
                       (Printf.sprintf "%s\n%s" cant_do_sentence
                          (Semantic.error_message semantic')))
                   p
                 |> run_on_string source
                 |> pretty_to_string ~origin (Some range)))
      else
        Error
          (Semantic.create_rendered ~brief:cant_do_sentence
             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
    let rendered =
      Report.pretty_report ~readonly_file_map ~with_unicode:true ~tab_size:4
        report
    in
    ThunkStrings.trim_lines_right rendered

  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
             ~brief:
               (brief_syntax ~cant_do_sentence
                  ~failed_expectations:(P.failed_expectations p) ())
             (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
               ~brief:(Semantic.error_brief semantic)
               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
               ~brief:
                 (brief_semantic ~cant_do_sentence ~failed_semantic:semantic ())
               range pretty_report)
      else
        Error
          (Semantic.create_rendered ~brief:cant_do_sentence
             Fmlib_parse.Position.(start, start)
             cant_do_sentence)
  end
end