Source file `Core.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
module Location = struct
  type t = { loc_start : Lexing.position; loc_end : Lexing.position }

  let none = { loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos }
end

let last_position = ref Location.none

exception Lexer_error of string

let provider ~debug buf =
  let start, stop = Sedlexing.lexing_positions buf in
  let token =
    match Tokenizer.tokenize buf with
    | Ok t -> t
    | Error e -> raise (Lexer_error e)
  in
  last_position := { loc_start = start; loc_end = stop };
  if debug then print_endline (Tokenizer.show_token token);
  (token, start, stop)

let menhir = MenhirLib.Convert.Simplified.traditional2revised Parser.program

let parse ?(debug = false) ?(colorize = true) ?(verbose = false) input :
    (Ast.expression, string) result =
  let _ = verbose in
  (* verbose will be used for parser warnings in the future *)
  let buf = Sedlexing.Utf8.from_string input in
  let next_token () = provider ~debug buf in
  match menhir next_token with
  | ast ->
      if debug then print_endline (Ast.show_expression ast);
      Ok ast
  | exception Lexer_error msg ->
      (* TODO: Do we want to show the lexing error differently than the parser error? *)
      if debug then (
        print_endline "Lexer error";
        print_endline msg);
      let Location.{ loc_start; loc_end; _ } = !last_position in
      Error
        (Console.Errors.make ~colorize ~input ~start:loc_start ~end_:loc_end)
  | exception _exn ->
      let Location.{ loc_start; loc_end; _ } = !last_position in
      Error
        (Console.Errors.make ~colorize ~input ~start:loc_start ~end_:loc_end)

let run ?(colorize = false) ?(verbose = false) query json =
  let result =
    parse ~colorize query |> Result.map (Compiler.compile ~colorize ~verbose)
    |> fun x ->
    Result.bind x (fun runtime ->
        match Json.parse_string json with
        | Ok input -> runtime input
        | Error err -> Error err)
  in
  match result with
  | Ok res ->
      Ok
        (res
        |> List.map (Json.to_string ~colorize ~summarize:false)
        |> String.concat "\n")
  | Error e -> Error e