first public release of the project
This commit is contained in:
Gabriel Scherer
@@ -0,0 +1,11 @@
|
||||
(executable
|
||||
(public_name minihell)
|
||||
(libraries constrained_generation menhirLib)
|
||||
(modules minihell)
|
||||
)
|
||||
|
||||
(executable
|
||||
(public_name minigen)
|
||||
(libraries constrained_generation)
|
||||
(modules minigen)
|
||||
)
|
||||
@@ -0,0 +1,55 @@
|
||||
type config = {
|
||||
exhaustive : bool;
|
||||
depth : int;
|
||||
count : int;
|
||||
seed : int option;
|
||||
}
|
||||
|
||||
let config =
|
||||
let exhaustive = ref false in
|
||||
let depth = ref 10 in
|
||||
let count = ref 1 in
|
||||
let seed = ref None in
|
||||
let usage =
|
||||
Printf.sprintf
|
||||
"Usage: %s [options]"
|
||||
Sys.argv.(0) in
|
||||
let spec = Arg.align [
|
||||
"--exhaustive", Arg.Set exhaustive,
|
||||
" Exhaustive enumeration";
|
||||
"--depth", Arg.Set_int depth,
|
||||
"<int> Depth of generated terms";
|
||||
"--count", Arg.Set_int count,
|
||||
"<int> Number of terms to generate";
|
||||
"--seed", Arg.Int (fun s -> seed := Some s),
|
||||
"<int> Fixed seed for the random number generator";
|
||||
] in
|
||||
Arg.parse spec (fun s -> raise (Arg.Bad s)) usage;
|
||||
{
|
||||
exhaustive = !exhaustive;
|
||||
depth = !depth;
|
||||
count = !count;
|
||||
seed = !seed;
|
||||
}
|
||||
|
||||
let () =
|
||||
match config.seed with
|
||||
| None -> Random.self_init ()
|
||||
| Some s -> Random.init s
|
||||
|
||||
module RandGen = Generator.Make(MRand)
|
||||
module SeqGen = Generator.Make(MSeq)
|
||||
|
||||
let () =
|
||||
begin
|
||||
if config.exhaustive then
|
||||
MSeq.run @@ SeqGen.typed ~depth:config.depth
|
||||
else
|
||||
MRand.run @@ RandGen.typed ~depth:config.depth
|
||||
end
|
||||
|> Seq.take config.count
|
||||
|> Seq.map STLCPrinter.print_term
|
||||
|> List.of_seq
|
||||
|> PPrint.(separate (hardline ^^ hardline))
|
||||
|> Utils.string_of_doc
|
||||
|> print_endline
|
||||
+165
@@ -0,0 +1,165 @@
|
||||
(* We instantiate the machinery with the Empty functor,
|
||||
which forbids any use of the Do constructor. *)
|
||||
module Untyped = Untyped.Make(Utils.Empty)
|
||||
module UntypedPrinter = UntypedPrinter.Make(Utils.Empty)
|
||||
module Constraint = Constraint.Make(Utils.Empty)
|
||||
module Infer = Infer.Make(Utils.Empty)
|
||||
module ConstraintPrinter = ConstraintPrinter.Make(Utils.Empty)
|
||||
module Solver = Solver.Make(Utils.Empty)
|
||||
|
||||
type config = {
|
||||
show_source : bool;
|
||||
show_constraint : bool;
|
||||
log_solver : bool;
|
||||
show_type : bool;
|
||||
show_typed_term : bool;
|
||||
}
|
||||
|
||||
module LexUtil = MenhirLib.LexerUtil
|
||||
|
||||
let print_section header doc =
|
||||
doc
|
||||
|> Printer.with_header header
|
||||
|> Utils.string_of_doc
|
||||
|> print_endline
|
||||
|> print_newline
|
||||
|
||||
let call_parser ~config parser_fun input_path =
|
||||
let ch = open_in input_path in
|
||||
Fun.protect ~finally:(fun () -> close_in ch) @@ fun () ->
|
||||
let lexbuf = Lexing.from_channel ch in
|
||||
let lexbuf = LexUtil.init input_path lexbuf in
|
||||
match parser_fun UntypedLexer.read lexbuf with
|
||||
| term ->
|
||||
let term = Untyped.freshen term in
|
||||
if config.show_source then
|
||||
print_section "Input term"
|
||||
(UntypedPrinter.print_term term);
|
||||
term
|
||||
| exception UntypedParser.Error ->
|
||||
let open Lexing in
|
||||
let start = lexbuf.lex_start_p in
|
||||
let stop = lexbuf.lex_curr_p in
|
||||
let loc =
|
||||
let line pos = pos.pos_lnum in
|
||||
let column pos = pos.pos_cnum - pos.pos_bol in
|
||||
if start.pos_lnum = stop.pos_lnum then
|
||||
Printf.sprintf "%d.%d-%d"
|
||||
(line start)
|
||||
(line stop) (column stop)
|
||||
else
|
||||
Printf.sprintf "%d.%d-%d.%d"
|
||||
(line start) (column start)
|
||||
(line stop) (column stop)
|
||||
in
|
||||
Printf.ksprintf failwith
|
||||
"%s:%s: syntax error"
|
||||
(Filename.quote input_path)
|
||||
loc
|
||||
|
||||
let call_typer ~config (term : Untyped.term) =
|
||||
let cst =
|
||||
let w = Constraint.Var.fresh "final_type" in
|
||||
Constraint.(Exist (w, None,
|
||||
Conj(Infer.has_type Untyped.Var.Map.empty term w,
|
||||
Infer.decode w)))
|
||||
in
|
||||
if config.show_constraint then
|
||||
print_section "Generated constraint"
|
||||
(ConstraintPrinter.print_constraint cst);
|
||||
let logs, result =
|
||||
let logs, env, nf =
|
||||
Solver.eval ~log:config.log_solver Unif.Env.empty cst
|
||||
in
|
||||
let result =
|
||||
match nf with
|
||||
| NRet v -> Ok (v (Decode.decode env))
|
||||
| NErr e -> Error e
|
||||
| NDo _ -> .
|
||||
in
|
||||
logs, result
|
||||
in
|
||||
if config.log_solver then
|
||||
print_section "Constraint solving log"
|
||||
PPrint.(separate hardline logs);
|
||||
result
|
||||
|
||||
let print_result ~config result =
|
||||
match result with
|
||||
| Ok (term, ty) ->
|
||||
if config.show_type then
|
||||
print_section "Inferred type"
|
||||
(STLCPrinter.print_ty ty);
|
||||
if config.show_typed_term then
|
||||
print_section "Elaborated term"
|
||||
(STLCPrinter.print_term term);
|
||||
| Error err ->
|
||||
print_section "Error" (match err with
|
||||
| Infer.Clash (ty1, ty2) ->
|
||||
Printer.incompatible
|
||||
(STLCPrinter.print_ty ty1)
|
||||
(STLCPrinter.print_ty ty2)
|
||||
| Infer.Cycle (Utils.Cycle v) ->
|
||||
Printer.cycle
|
||||
(Printer.inference_variable
|
||||
(Constraint.Var.print v))
|
||||
)
|
||||
|
||||
let process ~config input_path =
|
||||
let ast =
|
||||
call_parser ~config UntypedParser.term_eof input_path in
|
||||
let result =
|
||||
call_typer ~config ast in
|
||||
let () =
|
||||
print_result ~config result in
|
||||
()
|
||||
;;
|
||||
|
||||
let parse_args () =
|
||||
let show_source = ref false in
|
||||
let show_constraint = ref false in
|
||||
let log_solver = ref false in
|
||||
let show_type = ref true in
|
||||
let show_typed_term = ref true in
|
||||
let inputs = Queue.create () in
|
||||
let add_input path = Queue.add path inputs in
|
||||
let usage =
|
||||
Printf.sprintf
|
||||
"Usage: %s [options] <filenames>"
|
||||
Sys.argv.(0) in
|
||||
let spec = Arg.align [
|
||||
"--show-source",
|
||||
Arg.Set show_source,
|
||||
" Show input source";
|
||||
"--show-constraint",
|
||||
Arg.Set show_constraint,
|
||||
" Show the generated constraint";
|
||||
"--log-solver",
|
||||
Arg.Set log_solver,
|
||||
" Log intermediate constraints during solving";
|
||||
"--show-type",
|
||||
Arg.Set show_type,
|
||||
" Show the inferred type (or error)";
|
||||
"--show-typed-term",
|
||||
Arg.Set show_typed_term,
|
||||
" Show the inferred type (or error)";
|
||||
] in
|
||||
Arg.parse spec add_input usage;
|
||||
let config =
|
||||
{
|
||||
show_source = !show_source;
|
||||
show_constraint = !show_constraint;
|
||||
log_solver = !log_solver;
|
||||
show_type = !show_type;
|
||||
show_typed_term = !show_typed_term;
|
||||
}
|
||||
in
|
||||
let input_paths = (inputs |> Queue.to_seq |> List.of_seq) in
|
||||
config, input_paths
|
||||
|
||||
let () =
|
||||
let config, input_paths = parse_args () in
|
||||
List.iteri (fun i input ->
|
||||
if i > 0 then print_newline ();
|
||||
process ~config input
|
||||
) input_paths
|
||||
Reference in New Issue
Block a user