Simon Génier pushed to branch macro-expansion-tracing at Stefan / Typer
Commits: aab41237 by Simon Génier at 2022-02-16T19:00:53-05:00 Add a flag to show macros, their arguments and the expanded code.
- - - - -
3 changed files:
- src/elab.ml - src/log.ml - typer.ml
Changes:
===================================== src/elab.ml ===================================== @@ -97,6 +97,12 @@ let lexp_fatal loc lexp = let value_fatal loc value = fatal ~loc ~print_action:(value_print_details value)
+let macro_tracing_enabled = ref false +let trace_macro location fmt = + if !macro_tracing_enabled + then Log.log_debug ~loc:location ~section:"MACRO" fmt + else Printf.ifprintf () fmt + (** Type info returned by elaboration. *) type sform_type = | Checked (* Checked that the expression has the requested type. *) @@ -919,21 +925,34 @@ and check_case rtype (loc, target, ppatterns) ctx =
mkCase (loc, tlxp, rtype, lpattern, dflt)
-and elab_macro_call ctx func args ot = - let t - = match ot with - | None -> newMetatype (ectx_to_lctx ctx) (ectx_to_scope_level ctx) - (lexp_location func) - | Some t -> t in - let sxp = match lexp_expand_macro (lexp_location func) - func args ctx (Some t) with +and elab_macro_call + (ctx : elab_context) + (func : lexp) + (args : token list) + (ot : ltype option) + : lexp * sform_type = + + let location = lexp_location func in + let t = + match ot with + | None -> newMetatype (ectx_to_lctx ctx) (ectx_to_scope_level ctx) location + | Some t -> t + in + + trace_macro location {|expanding: %s|} (lexp_string func); + List.iteri + (fun i arg -> arg |> sexp_string |> trace_macro location {|input %d: %s|} i) + args; + let sxp = + match lexp_expand_macro location func args ctx (Some t) with | Vcommand cmd -> (match cmd () with - | Vsexp (sxp) -> sxp - | v -> value_fatal (lexp_location func) v - "Macros should return a IO Sexp") - | v -> value_fatal (lexp_location func) v - "Macros should return an IO" in + | Vsexp (sxp) -> sxp + | v -> value_fatal location v "Macros should return a IO Sexp") + | v -> value_fatal location v "Macros should return an IO" + in + trace_macro location {|output: %s|} (sexp_string sxp); + elaborate ctx sxp ot
(* Identify Call Type and return processed call. *)
===================================== src/log.ml ===================================== @@ -114,15 +114,15 @@ let maybe_color_string color_opt str = | None -> str
let string_of_log_entry {level; kind; section; loc; msg; _} = - let color = if typer_log_config.color then (level_color level) else None in + let color = if typer_log_config.color then level_color level else None in + let kind_string = Option.value ~default:(string_of_level level) kind in let parens s = "(" ^ s ^ ")" in - (Option.value ~default:"" (Option.map Source.Location.to_string loc) - ^ maybe_color_string - color - (Option.value ~default:(string_of_level level) kind) - ^ ":" - ^ Option.value ~default:"" (Option.map parens section) ^ " " - ^ msg) + sprintf + "%s %s:%s %s" + (Option.value ~default:"" (Option.map Source.Location.to_string loc)) + (maybe_color_string color kind_string) + (Option.value ~default:"" (Option.map parens section)) + msg
let print_entry entry = print_endline (string_of_log_entry entry);
===================================== typer.ml ===================================== @@ -40,12 +40,22 @@ let arg_defs =
("-Vfull-lctx", Arg.Set Debruijn.log_full_lctx, - "Print the full lexp context on error."); + "Print the full lexp context on error"); + + ("-Vmacro-expansion", + Arg.Set Elab.macro_tracing_enabled, + "Trace macro expansion"); ]
+let parse_args argv usage = + try Arg.parse_argv argv arg_defs add_input_file usage with + | Arg.Help (message) -> + print_string message; + exit 0 + let compile_main argv = let usage = Sys.executable_name ^ " compile [options] <file> …" in - Arg.parse_argv argv arg_defs add_input_file usage; + parse_args argv usage;
let ectx = Elab.default_ectx in let backend = new Gambit.gambit_compiler (ectx_to_lctx ectx) stdout in @@ -57,7 +67,7 @@ let compile_main argv =
let repl_main argv = let usage = Sys.executable_name ^ " repl [options] [<file>] …" in - Arg.parse_argv argv arg_defs add_input_file usage; + parse_args argv usage;
print_string (Fmt.make_title " TYPER REPL "); print_endline " Typer 0.0.0 - Interpreter - (c) 2016-2021"; @@ -80,7 +90,7 @@ let repl_main argv =
let run_main argv = let usage = Sys.executable_name ^ " run [options] <file> …" in - Arg.parse_argv argv arg_defs add_input_file usage; + parse_args argv usage;
let ectx = Elab.default_ectx in let backend = new Eval.ast_interpreter (ectx_to_lctx ectx) in
View it on GitLab: https://gitlab.com/monnier/typer/-/commit/aab4123773bc2a397fcb6a0fc2fe660453...