Something went wrong. Try again.
forked from gbury/dolmen
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174
(* This file is free software, part of dolmen. See file "LICENSE" for more information *)
(* Debug printing *)(* ************** *)
let debug_parsed_pipe st c = if Loop.State.get Loop.State.debug st then Format.eprintf "[logic][parsed][%a] @[<hov>%a@]@." Dolmen.Std.Loc.print_compact c.Dolmen.Std.Statement.loc Dolmen.Std.Statement.print c; st, c
let debug_typed_pipe st stmts = if Loop.State.get Loop.State.debug st then begin List.iter (fun stmt -> Format.eprintf "[logic][typed][%a] @[<hov>%a@]@\n" Dolmen.Std.Loc.print_compact stmt.Loop.Typer_Pipe.loc Loop.Typer_Pipe.print stmt) stmts; Format.eprintf "@."; end; st, stmts
(* Run dolmen (regular use) *)(* ************************ *)
let handle_exn st bt exn = let _st = Errors.exn st bt exn in exit 125
let finally st e = match e with | None -> st | Some (bt,exn) -> handle_exn st bt exn
let run st preludes logic_file = if Loop.State.get Loop.State.debug st then begin Dolmen.Std.Expr.Print.print_tags := true; Dolmen.Std.Expr.Print.print_index := true; () end; let g = try Loop.Parser.parse_logic ~preludes logic_file with exn -> let bt = Printexc.get_raw_backtrace () in handle_exn st bt exn in let st = let open Loop.Pipeline in run ~finally g st ( (fix (op ~name:"expand" Loop.Parser.expand) ( (op ~name:"debug-parsed" debug_parsed_pipe) @>>> (op ~name:"flow" Loop.Flow.inspect) @>>> (op ~name:"headers" Loop.Header.inspect) @>>> (op ~name:"typecheck" Loop.Typer_Pipe.typecheck) @>|> (op ~name:"debug-typed" debug_typed_pipe) @>>> (op ~name:"check" Loop.Check.check) @>>> (op ~name:"transform" Loop.Transform.transform) @>>> (op ~name:"export" Loop.Export.export) @>>> (op (fun st _ -> st, ())) @>>> _end ) ) ) in let st = Dolmen_loop.State.flush st () in ignore st
(* Warning/Error list *)(* ****************** *)
let list conf = let open Dolmen_loop in let l = List.sort (fun r r' -> String.compare (Report.T.mnemonic r) (Report.T.mnemonic r') ) (Report.T. list ()) in let pp_kind fmt = function | `All -> Format.fprintf fmt "%-15s" "group" | `Error _ -> Format.fprintf fmt "%-15s" "error" | `Warning Report.Any_warn w -> Format.fprintf fmt "w:%-13s" (Report.Warning.Status.to_string (Report.Conf.status conf w)) in Format.printf "%-30s%-15s%-15s%s@\n%s@\n" "mnemonic" "kind" "category" "description" (String.make 100 '-'); List.iter (fun t -> Format.printf "%-30s%a%-15s%s@\n" (Report.T.mnemonic t) pp_kind t (Report.T.category t) (Report.T.name t) ) l
(* Warning/Error documentation *)(* *************************** *)
let doc conf t = let open Dolmen_loop in let pp_status fmt = function | `All | `Error _ -> () | `Warning Report.Any_warn w -> Format.fprintf fmt "@ By default: %a" Report.Warning.Status.print (Report.Conf.status conf w) in Format.printf "@[<v>@ %s@ @ kind: %s@ Category: %s@ Mnemonic: %s%a@ @ @[<hov> %t@]@]@." (Report.T.name t) (Report.T.kind t) (Report.T.category t) (Report.T.mnemonic t) pp_status t (Report.T.doc t)
(* Extensions list *)(* *************** *)
let conflicting_extensions = Dolmen_loop.Report.Warning.mk ~mnemonic:"conflicting-extensions" ~message:(fun ppf conflicts -> let conflicts = List.init 2 (fun _ -> conflicts) in let conflicts = List.concat conflicts in Fmt.pf ppf "@[<hov 2>@[%a@]:@ %a@]" Fmt.words "The following external extensions are shadowed by builtin extensions \ and will never be loaded" Fmt.(hovbox @@ list ~sep:Fmt.comma (box string)) conflicts ) ~name:"Conflicting extensions" ()
let list_extensions st = begin match Extensions.list_conflicts () with | [] -> () | conflicts -> ignore (Loop.State.warn st conflicting_extensions conflicts) end; Format.printf "%a@." Fmt.(vbox @@ list (box Extensions.pp)) (Extensions.list ())
(* Main code *)(* ********* *)
let () = let version = "0.10" in let exits = List.map (fun code -> let retcode, doc = Dolmen_loop.Code.descr code in Cmdliner.Cmd.Exit.info ~doc retcode ) (Dolmen_loop.Code.errors ()) @ Cmdliner.Cmd.Exit.defaults in let cli_term = Cmdliner.Cmd.v (Cmdliner.Cmd.info "dolmen" ~exits ~man:Man.cli ~version) Options.cli in match Cmdliner.Cmd.eval_value cli_term with | Ok (`Version | `Help) -> exit 0 | Error (`Parse | `Term | `Exn) -> exit Cmdliner.Cmd.Exit.cli_error | Ok (`Ok Run { state ; preludes; logic_file }) -> run state preludes logic_file | Ok (`Ok Doc { report; conf; }) -> doc conf report | Ok (`Ok List_reports { conf; }) -> list conf | Ok (`Ok List_extensions { state }) -> list_extensions state