From bb82204659be7a3c07106f8d351fefcee553c2aa Mon Sep 17 00:00:00 2001 From: Patrycja Balik Date: Sat, 20 Jul 2024 08:13:55 +0200 Subject: [PATCH 1/2] Fix visibility of module patterns (#140) Fixes #138. --- src/DblParser/Desugar.ml | 2 +- src/Lang/Surface.ml | 2 +- src/TypeInference/Pattern.ml | 4 ++-- test/ok/ok0110_publicModulePattern.fram | 6 ++++++ 4 files changed, 10 insertions(+), 4 deletions(-) create mode 100644 test/ok/ok0110_publicModulePattern.fram diff --git a/src/DblParser/Desugar.ml b/src/DblParser/Desugar.ml index 8eecc3d..0605e6e 100644 --- a/src/DblParser/Desugar.ml +++ b/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)) diff --git a/src/Lang/Surface.ml b/src/Lang/Surface.ml index 41144fd..d01f0d6 100644 --- a/src/Lang/Surface.ml +++ b/src/Lang/Surface.ml @@ -159,7 +159,7 @@ and pattern_data = and ctor_pattern_named = | CNParams of named_type_arg list * named_pattern list (** Named type parameters and named patterns of a constructor *) - | CNModule of module_name + | CNModule of is_public * module_name (** Bind all named parameters under the specified module name *) (** Pattern for named parameter *) diff --git a/src/TypeInference/Pattern.ml b/src/TypeInference/Pattern.ml index 2a2a2a9..7de73db 100644 --- a/src/TypeInference/Pattern.ml +++ b/src/TypeInference/Pattern.ml @@ -201,13 +201,13 @@ let rec check_ctor_named ~pos ~env ~scope let (env, bn1, ps1) = check_ctor_named_args ~pos ~env ~scope nps ctor_named in (env, scope, sub2, tvars, ps1, bn1) - | S.CNModule modname -> + | S.CNModule(public, modname) -> (* TODO: This may seem inconsistent with the other case as implicits aren't introduced to the current namespace, just the provided module name. *) let env = Env.enter_module env in let (env, tvars, ps1, sub2) = open_named ~pos ~public:true env ctor.ctor_targs ctor.ctor_named in - let env = Env.leave_module env ~public:false modname in + let env = Env.leave_module env ~public modname in (env, Env.scope env, sub2, tvars, ps1, T.Name.Map.empty) and check_ctor_named_args ~pos ~env ~scope nps named = diff --git a/test/ok/ok0110_publicModulePattern.fram b/test/ok/ok0110_publicModulePattern.fram new file mode 100644 index 0000000..c01f13d --- /dev/null +++ b/test/ok/ok0110_publicModulePattern.fram @@ -0,0 +1,6 @@ +module M + data T = C of { x : Int } + pub let C { module N } = C { x = 42 } +end + +let x = M.N.x From ac60ba677d2817644451a687d007aaee06619755 Mon Sep 17 00:00:00 2001 From: Foxinio <54729600+Foxinio@users.noreply.github.com> Date: Thu, 8 Aug 2024 21:21:30 +0200 Subject: [PATCH 2/2] Better printing of error position in REPL and with colors (#135) Co-authored-by: Piotr Polesiuk --- .github/workflows/Test.yml | 2 +- dune-project | 7 +- src/DblConfig.ml | 12 ++ src/DblParser/Main.ml | 12 +- src/InterpLib/Error.ml | 25 +++- src/InterpLib/Error.mli | 3 + src/InterpLib/TextRangePrinting.ml | 202 ++++++++++++++++++++++++++++ src/InterpLib/TextRangePrinting.mli | 52 +++++++ src/InterpLib/dune | 2 +- src/TypeInference/Error.ml | 30 +++-- src/Utils/Position.ml | 113 ---------------- src/dbl.ml | 6 + src/dune | 5 +- 13 files changed, 334 insertions(+), 137 deletions(-) create mode 100644 src/InterpLib/TextRangePrinting.ml create mode 100644 src/InterpLib/TextRangePrinting.mli diff --git a/.github/workflows/Test.yml b/.github/workflows/Test.yml index ee56d38..d769ab2 100644 --- a/.github/workflows/Test.yml +++ b/.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 - \ No newline at end of file + diff --git a/dune-project b/dune-project index 00bc525..7de31d3 100644 --- a/dune-project +++ b/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)))) diff --git a/src/DblConfig.ml b/src/DblConfig.ml index 378115b..b9aafb7 100644 --- a/src/DblConfig.ml +++ b/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 + diff --git a/src/DblParser/Main.ml b/src/DblParser/Main.ml index 5a4a40a..7a57185 100644 --- a/src/DblParser/Main.ml +++ b/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 = "" @@ -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 diff --git a/src/InterpLib/Error.ml b/src/InterpLib/Error.ml index 6ec280b..96c5dd5 100644 --- a/src/InterpLib/Error.ml +++ b/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 diff --git a/src/InterpLib/Error.mli b/src/InterpLib/Error.mli index 76290d6..6361714 100644 --- a/src/InterpLib/Error.mli +++ b/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 diff --git a/src/InterpLib/TextRangePrinting.ml b/src/InterpLib/TextRangePrinting.ml new file mode 100644 index 0000000..5d06c65 --- /dev/null +++ b/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 = "" && repl_input <> "" then + get_text_from_repl ~options ~repl_input ~color_printer pos + else + get_text_from_file ~options ~color_printer pos diff --git a/src/InterpLib/TextRangePrinting.mli b/src/InterpLib/TextRangePrinting.mli new file mode 100644 index 0000000..0878487 --- /dev/null +++ b/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 diff --git a/src/InterpLib/dune b/src/InterpLib/dune index a2e5980..a7ffadd 100644 --- a/src/InterpLib/dune +++ b/src/InterpLib/dune @@ -1,3 +1,3 @@ (library (name interpLib) - (libraries utils)) + (libraries utils dblConfig str)) diff --git a/src/TypeInference/Error.ml b/src/TypeInference/Error.ml index 10d9706..8d7b37c 100644 --- a/src/TypeInference/Error.ml +++ b/src/TypeInference/Error.ml @@ -108,7 +108,8 @@ let unbound_method ~pos ~env x name = let method_fn_without_arg ~pos x name = (pos, Printf.sprintf - "Variable %s is registered as method %s and cannot be used without argument" + ("Variable %s is registered as method %s" + ^^ " and cannot be used without argument") (string_of_path x) name, []) let expr_type_mismatch ~pos ~env tp1 tp2 = @@ -122,7 +123,8 @@ let expr_type_mismatch ~pos ~env tp1 tp2 = let expr_effect_mismatch ~pos ~env eff1 eff2 = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "This expression has effect %s, but an expression was expected of effect %s" + ("This expression has effect %s, but" + ^^ " an expression was expected of effect %s") (Pretty.type_to_string pp_ctx env eff1) (Pretty.type_to_string pp_ctx env eff2) in (pos, msg ^ Pretty.additional_info pp_ctx, []) @@ -150,7 +152,8 @@ let delim_effect_mismatch ~pos ~env eff1 eff2 = let pattern_type_mismatch ~pos ~env tp1 tp2 = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "This pattern matches values of type %s, but it was expected to match values of type %s" + ("This pattern matches values of type %s," + ^^ " but it was expected to match values of type %s") (Pretty.type_to_string pp_ctx env tp1) (Pretty.type_to_string pp_ctx env tp2) in (pos, msg ^ Pretty.additional_info pp_ctx, []) @@ -158,7 +161,8 @@ let pattern_type_mismatch ~pos ~env tp1 tp2 = let pattern_annot_mismatch ~pos ~env sch1 sch2 = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "Annotating pattern with type %s, but it was expected to match values of type %s" + ("Annotating pattern with type %s, but" + ^^ " it was expected to match values of type %s") (Pretty.scheme_to_string pp_ctx env sch2) (Pretty.scheme_to_string pp_ctx env sch1) in (pos, msg ^ Pretty.additional_info pp_ctx, []) @@ -166,7 +170,8 @@ let pattern_annot_mismatch ~pos ~env sch1 sch2 = let func_effect_mismatch ~pos ~env eff1 eff2 = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "This function has effect %s, but it is applied in a context that accepts effect %s" + ("This function has effect %s, but" + ^^ " it is applied in a context that accepts effect %s") (Pretty.type_to_string pp_ctx env eff1) (Pretty.type_to_string pp_ctx env eff2) in (pos, msg ^ Pretty.additional_info pp_ctx, []) @@ -174,7 +179,8 @@ let func_effect_mismatch ~pos ~env eff1 eff2 = let method_effect_mismatch ~pos ~env eff1 eff2 = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "This method has effect %s, but it is applied in a context that accepts effect %s" + ("This method has effect %s, but it is applied" + ^^ " in a context that accepts effect %s") (Pretty.type_to_string pp_ctx env eff1) (Pretty.type_to_string pp_ctx env eff2) in (pos, msg ^ Pretty.additional_info pp_ctx, []) @@ -291,7 +297,8 @@ let empty_match_on_non_adt ~pos ~env tp = let empty_match_on_nonempty_adt ~pos ~env tp = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "This pattern matching matches values of type %s, which is not an empty ADT" + ("This pattern matching matches values of type %s," + ^^ " which is not an empty ADT") (Pretty.type_to_string pp_ctx env tp) in (pos, msg ^ Pretty.additional_info pp_ctx, []) @@ -368,7 +375,8 @@ let looping_named_param ~pos name = let named_param_type_mismatch ~pos ~env name tp1 tp2 = let pp_ctx = Pretty.empty_context () in let msg = Printf.sprintf - "Type error during resolving of implicit parameters: %s has type %s, but the expected type is %s" + ("Type error during resolving of implicit " + ^^ "parameters: %s has type %s, but the expected type is %s") (string_of_name name) (Pretty.type_to_string pp_ctx env tp1) (Pretty.type_to_string pp_ctx env tp2) @@ -431,7 +439,8 @@ let type_generalized_twice ~pos name = let ctor_arity_mismatch ~pos cpath req_n prov_n = (pos, - Printf.sprintf "Constructor %s expects %d parameter(s), but is applied to %d" + Printf.sprintf + "Constructor %s expects %d parameter(s), but is applied to %d" (string_of_path cpath) req_n prov_n, []) @@ -442,7 +451,8 @@ let redundant_named_type ~pos (name : Lang.Unif.tname) = | TNAnon -> assert false | TNVar x -> Printf.sprintf "type %s" x in - (pos, Printf.sprintf "Providing %s to a function that do not expect it" nn, []) + (pos, Printf.sprintf + "Providing %s to a function that do not expect it" nn, []) let redundant_named_parameter ~pos name = (pos, diff --git a/src/Utils/Position.ml b/src/Utils/Position.ml index 49c14a7..d12663f 100644 --- a/src/Utils/Position.ml +++ b/src/Utils/Position.ml @@ -96,116 +96,3 @@ let to_string pos = pos.pos_fname pos.pos_start_line (start_column pos) pos.pos_end_line (end_column pos) - -module PrettyPrinting = -struct - (** 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 : 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 = 1; - underline = (fun _ -> UnderlineIfOneLine); - add_line_numbers = true; - } - -end - -(** Get text from file from given position *) -let get_text_range ?(options = PrettyPrinting.default_options) ?channel (pos : t) = - 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 - in - let generate_underline start_cnum len tabs = - if len <= 0 then "" else - let underline = String.make len '^' in - let padding = String.make (start_cnum - 1) ' ' in - String.mapi (fun i _ -> if List.mem i tabs then '\t' else ' ') padding ^ underline - in - let add_underline (i, line) : (int option * string) Seq.t = - 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 (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 (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 - (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 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 0 (String.length line) (find_tabs line) in - Seq.cons (i, line) (Seq.return (None, underline)) - | UnderlineAlways, _ -> Seq.return (i, line) - in - let add_line_number 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 line else - match i with - | None -> String.make (align_to + 3) ' ' ^ "| " ^ line - | Some i -> - Printf.sprintf " %*d | %s" (align_to + 1) i line - in - let process_file fd = - let lines = Seq.of_dispenser (fun () -> In_channel.input_line fd) - |> Seq.zip (Seq.ints 1 |> Seq.map Option.some) - |> Seq.drop (pos.pos_start_line - 1 - options.context |> Int.max 0) - |> Seq.take (pos.pos_end_line - pos.pos_start_line + 1 + 2*options.context) - |> Seq.flat_map add_underline - |> Seq.map (add_line_number pos.pos_end_line) - in - String.concat "\n" @@ List.of_seq lines - in - if Fun.negate Sys.file_exists pos.pos_fname then None else - let file_chunk = match channel with - | None -> In_channel.with_open_text pos.pos_fname process_file - | Some ch -> process_file ch - in - let pp_file_name = " -> " ^ pos.pos_fname ^ "\n" in - Some (pp_file_name ^ file_chunk) diff --git a/src/dbl.ml b/src/dbl.ml index 3876e95..b91e273 100644 --- a/src/dbl.ml +++ b/src/dbl.ml @@ -46,6 +46,12 @@ let cmd_args_options = Arg.align "-I", Arg.String (fun p -> cli_local_search_dirs := p :: !cli_local_search_dirs), " Add a path to local search directories"; + + "-color", + Arg.Symbol ( + [ "always"; "never"; "auto"; ], + (fun s -> DblConfig.print_colors_of_string s)), + " Use colors when printing Errors."; ] let fname = ref None diff --git a/src/dune b/src/dune index 5881e72..5615950 100644 --- a/src/dune +++ b/src/dune @@ -1,10 +1,11 @@ (library (name dblConfig) - (modules dblConfig)) + (modules dblConfig) + (libraries unix)) (executable (name dbl) (modes byte exe) (public_name dbl) - (libraries interpLib dblParser typeInference toCore eval) + (libraries interpLib dblParser typeInference toCore eval unix) (modules dbl pipeline typeErase))