Merge branch 'fram-lang:master' into master

Author: MinionJakub

.github/workflows/Test.yml

@@ -16,4 +16,4 @@ jobs:
       - run: opam exec -- dune build
       - run: opam exec -- dune install
       - run: eval $(opam env) && ./test.sh dbl ./test/test_suite
-      
+

dune-project

@@ -3,7 +3,12 @@
 
 (generate_opam_files true)
 
+(source (github fram-lang/dbl))
+(license MIT)
+
 (package
   (name dbl)
   (synopsis "Interpreter of Fram: a language with algebraic effects and powerful named parameters")
-  (description ""))
+  (description "")
+  (depends
+    (dune (>= 3.11))))

src/DblConfig.ml

@@ -20,3 +20,15 @@ let local_mod_prefix = "Main"
 
 let lib_search_dirs   : string list ref = ref [ ]
 let local_search_dirs : string list ref = ref [ ]
+
+let print_colors_auto () =
+  Unix.isatty Unix.stdout
+
+let display_colors = ref (print_colors_auto ())
+
+let print_colors_of_string = function
+  | "always" -> display_colors := true
+  | "never"  -> display_colors := false
+  | "auto"   -> display_colors := print_colors_auto ()
+  | _ -> assert false
+

src/DblParser/Desugar.ml

@@ -316,7 +316,7 @@ let rec tr_pattern ~public (p : Raw.expr) =
     let ps = List.map (tr_pattern ~public) ps in
     begin match flds with
     | [ { data = FldModule name; _ } ] ->
-      make (PCtor(cpath, CNModule name, ps))
+      make (PCtor(cpath, CNModule(public, name), ps))
     | _ ->
       let (targs, iargs) = map_inst_like (tr_named_pattern ~public) flds in
       make (PCtor(cpath, CNParams(targs, iargs), ps))

src/DblParser/Main.ml

@@ -22,8 +22,14 @@ let rec repl_seq imported () =
 
 and repl_seq_main imported () =
   flush stderr;
+  Buffer.clear InterpLib.Error.repl_input;
+  let fn buf n =
+    let res = input stdin buf 0 n in
+    Buffer.add_subbytes InterpLib.Error.repl_input buf 0 res;
+    res
+  in
   Printf.printf "> %!";
-  let lexbuf = Lexing.from_channel stdin in
+  let lexbuf = Lexing.from_function fn in
   lexbuf.Lexing.lex_curr_p <-
     { lexbuf.Lexing.lex_curr_p with
       Lexing.pos_fname = "<stdin>"
@@ -38,8 +44,8 @@ and repl_seq_main imported () =
     Seq.Cons([def], repl_seq imported)
 
   | Raw.REPL_Defs defs ->
-      let defs = Desugar.tr_defs defs in
-      Seq.Cons(defs, repl_seq imported)
+    let defs = Desugar.tr_defs defs in
+    Seq.Cons(defs, repl_seq imported)
 
   | Raw.REPL_Import import ->
     let imported, defs = Import.import_one imported import in

src/InterpLib/Error.ml

@@ -14,22 +14,35 @@ type error_class =
 
 let err_counter = ref 0
 
+let repl_input = Buffer.create 512
+
 let incr_error_counter () =
   err_counter := !err_counter + 1
 
+let color_printer_generator color s =
+  if not !DblConfig.display_colors
+  then s
+  else TextRangePrinting.color_string color s
+
 let report ?pos ~cls msg =
-  let name =
+  let module Color = TextRangePrinting in
+  let name, color =
     match cls with
     | FatalError ->
       incr_error_counter ();
-      "fatal error"
+      "fatal error", Color.Red
     | Error ->
       incr_error_counter ();
-      "error"
-    | Warning -> "warning"
-    | Note    -> "note"
+      "error", Color.Red
+    | Warning -> "warning", Color.Yellow
+    | Note    -> "note", Color.Teal
   in
-  match pos, Option.bind pos Position.get_text_range with
+  let name = Color.color_string color name in
+  let text_range = Option.bind pos
+    (TextRangePrinting.get_text_range
+      ~repl_input:(Buffer.contents repl_input)
+      ~color) in
+  match pos, text_range with
   | Some pos, None ->
     Printf.eprintf "%s: %s: %s\n"
       (Position.to_string pos) name msg

src/InterpLib/Error.mli

@@ -35,3 +35,6 @@ val wrap_repl_cont : (unit -> 'a) -> unit -> 'a
 
 (** Reset state of reported errors. Used in REPL in case of an error. *)
 val reset : unit -> unit
+
+(** A buffer that contains last REPL input. *)
+val repl_input : Buffer.t

src/InterpLib/TextRangePrinting.ml

@@ -0,0 +1,202 @@
+(* This file is part of DBL, released under MIT license.
+ * See LICENSE for details.
+ *)
+
+(** Pretty printing of text range from Position.t *)
+open Position
+
+(* ========================================================================= *)
+(**  Options for underlining specified region  *)
+type underline_options =
+  | NoUnderline
+  (** Disable underlining *)
+
+  | UnderlineBegining
+  (** Point to only beginning of region *)
+
+  | UnderlineIfOneLine
+  (** Underline whole region, but only if specifies only one line *)
+
+  | UnderlineAlways
+  (** Underline whole region *)
+
+type options = {
+  context : int;
+  (** how many lines before region is to be printed *)
+
+  underline : t -> underline_options;
+  (** function that depending on region will select underlining option *)
+
+  add_line_numbers : bool;
+  (** should line numbers be added *)
+}
+
+let default_options = {
+  context = 2;
+  underline = (fun _ -> UnderlineIfOneLine);
+  add_line_numbers = true;
+}
+
+(* ========================================================================= *)
+(**  Printing to terminal with colors  *)
+
+let keyword_color = "\027[1;34m"
+
+type printing_color =
+  | Red
+  | Teal
+  | Yellow
+  | Black
+  | Green
+  | Blue
+  | Magenta
+  | Cyan
+  | White
+  | Default
+
+let color_to_string = function
+  | Black  -> "\027[30m"
+  | Red    -> "\027[31m"
+  | Green  -> "\027[32m"
+  | Yellow -> "\027[33m"
+  | Blue   -> "\027[34m"
+  | Magenta -> "\027[35m"
+  | Teal   -> "\027[36m"
+  | Cyan   -> "\027[36m"
+  | White  -> "\027[37m"
+  | Default -> "\027[0m"
+
+let bold_code_string = "\027[1m"
+let dim_code_string = "\027[2m"
+let italic_code_string = "\027[3m"
+let underline_code_string = "\027[4m"
+let blink_code_string = "\027[5m"
+let rapid_blink_code_string = "\027[6m"
+let reverse_code_string = "\027[7m"
+let hidden_code_string = "\027[8m"
+
+let reset_string = color_to_string Default
+
+let color_string color s =
+  if not !DblConfig.display_colors
+  then s
+  else color_to_string color ^ s ^ reset_string
+
+let bolden_string s =
+  if not !DblConfig.display_colors
+  then s
+  else bold_code_string ^ s ^ reset_string
+
+let underline_string s =
+  if not !DblConfig.display_colors
+  then s
+  else underline_code_string ^ s ^ reset_string
+
+(* ========================================================================= *)
+(**  Underlining   *)
+
+let find_tabs line =
+  String.fold_left (fun (i, acc) c ->
+      if c = '\t' then (i+1, i::acc) else (i+1, acc)) (0, []) line
+  |> snd
+
+let generate_underline ~color_printer start_cnum len tabs =
+  if len <= 0 then "" else
+  let underline = String.make len '^' |> color_printer in
+  let padding = String.make (start_cnum - 1) ' ' in
+  let f i _ =
+    if List.mem i tabs
+    then '\t'
+    else ' '
+  in String.mapi f padding ^ underline
+
+let add_underline ~options ~pos ~color_printer (i, line) =
+  match options.underline pos, i with
+  | NoUnderline, _ -> Seq.return (i, line)
+  | (UnderlineIfOneLine | UnderlineAlways), Some j
+      when pos.pos_start_line = pos.pos_end_line
+      && pos.pos_start_line = j ->
+    let underline = generate_underline ~color_printer
+        (start_column pos) pos.pos_length (find_tabs line) in
+    Seq.cons (i, line) (Seq.return (None, underline))
+  | UnderlineIfOneLine, _ -> Seq.return (i, line)
+  | UnderlineBegining, Some j
+      when pos.pos_start_line = j ->
+    let underline = generate_underline ~color_printer
+        (start_column pos) 1 (find_tabs line) in
+    Seq.cons (i, line) (Seq.return (None, underline))
+  | UnderlineBegining, _ -> Seq.return (i, line)
+  | UnderlineAlways, Some j
+      when j = pos.pos_start_line ->
+    let underline = generate_underline ~color_printer
+      (start_column pos)
+      (String.length line - start_column pos)
+      (find_tabs line) in
+    Seq.cons (i, line) (Seq.return (None, underline))
+  | UnderlineAlways, Some j
+      when j = pos.pos_end_line ->
+    let underline = generate_underline ~color_printer
+        0 (end_column pos) (find_tabs line) in
+    Seq.cons (i, line) (Seq.return (None, underline))
+  | UnderlineAlways, Some j
+      when j > pos.pos_start_line && j < pos.pos_end_line ->
+    let underline = generate_underline ~color_printer
+        0 (String.length line) (find_tabs line) in
+    Seq.cons (i, line) (Seq.return (None, underline))
+  | UnderlineAlways, _ -> Seq.return (i, line)
+
+(* ========================================================================= *)
+(**  Printing code   *)
+
+let add_line_number ~options ~pos ~color_printer end_line =
+  let align_to = Float.of_int end_line
+    |> Float.log10
+    |> Float.to_int
+  in
+  fun (i, line) ->
+    if not options.add_line_numbers then
+      String.make (align_to + 3) ' ' ^ "| " ^ line
+    else
+    match i with
+    | None -> String.make (align_to + 3) ' ' ^ "| " ^ line
+    | Some i ->
+      let separator = if i >= pos.pos_start_line && i <= pos.pos_end_line
+        then color_printer "|>" else "| " in
+      Printf.sprintf " %*d %s%s" (align_to + 1) i separator line
+
+let process ~pos ~options ~color_printer seq =
+  let to_drop = pos.pos_start_line - 1 - options.context in
+  let to_take =
+      pos.pos_end_line - pos.pos_start_line + 1 +
+      options.context - (Int.min 0 to_drop) in
+  let lines = seq
+    |> Seq.zip (Seq.ints 1 |> Seq.map Option.some)
+    |> Seq.drop (Int.max to_drop 0)
+    |> Seq.take to_take
+    |> Seq.flat_map (add_underline ~options ~pos ~color_printer)
+    |> Seq.map (add_line_number pos.pos_end_line ~options ~pos ~color_printer)
+  in
+  String.concat "\n" @@ List.of_seq lines
+
+let get_text_from_repl ~options ~repl_input ~color_printer pos =
+  let lines = String.split_on_char '\n' repl_input in
+  let options = { options with add_line_numbers=false } in
+  let file_chunk = process ~pos ~options
+      ~color_printer (List.to_seq lines) in
+  Some file_chunk
+
+let get_text_from_file ~options ~color_printer pos =
+  if Fun.negate Sys.file_exists pos.pos_fname then None else
+  let get_line fd () = In_channel.input_line fd in
+  let process_file fd = process ~pos ~options ~color_printer
+      (Seq.of_dispenser (get_line fd)) in
+  let file_chunk = In_channel.with_open_text pos.pos_fname process_file in
+  let pp_file_name = " -> " ^ pos.pos_fname ^ "\n" in
+  Some (pp_file_name ^ file_chunk)
+
+let get_text_range ?(options=default_options) ~repl_input ~color (pos : t) =
+  let color_printer = color_string color in
+  if pos.pos_fname = "<stdin>" && repl_input <> "" then
+    get_text_from_repl ~options ~repl_input ~color_printer pos
+  else
+    get_text_from_file ~options ~color_printer pos

src/InterpLib/TextRangePrinting.mli

@@ -0,0 +1,52 @@
+(* This file is part of DBL, released under MIT license.
+ * See LICENSE for details.
+ *)
+
+(* ========================================================================= *)
+(** Printing to terminal with colors *)
+type printing_color =
+  | Red
+  | Teal
+  | Yellow
+  | Black
+  | Green
+  | Blue
+  | Magenta
+  | Cyan
+  | White
+  | Default
+
+val color_string : printing_color -> string -> string
+val bolden_string : string -> string
+val underline_string : string -> string
+
+(* ========================================================================= *)
+(** Options for underlining specified region *)
+type underline_options =
+  | NoUnderline
+  (** Disable underlining *)
+
+  | UnderlineBegining
+  (** Point to only beginning of region *)
+
+  | UnderlineIfOneLine
+  (** Underline whole region, but only if specifies only one line *)
+
+  | UnderlineAlways
+  (** Underline whole region *)
+
+type options = {
+  context : int;
+  (** how many lines before and after region is to be printed *)
+
+  underline : Position.t -> underline_options;
+  (** function that depending on region will select underlining option *)
+
+  add_line_numbers : bool;
+  (** should line numbers be added *)
+}
+
+val default_options : options 
+
+val get_text_range : ?options:options -> repl_input:string
+      -> color:printing_color -> Position.t -> string option

src/InterpLib/dune

@@ -1,3 +1,3 @@
 (library
   (name interpLib)
-  (libraries utils))
+  (libraries utils dblConfig str))