From 10d43dc33c9b0ddc2286eadb4e1a9b51eb465f13 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Apr 2020 14:01:16 +0200 Subject: [PATCH 1/3] nicer error messages in compiler --- src/compiler.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/compiler.ml b/src/compiler.ml index 10d405750..d3e946468 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -1617,7 +1617,8 @@ end = struct (* {{{ *) let rec spaux (depth,vars as ctx) = function | App(c, fcall, rest) when c == D.Global_symbols.spillc -> - assert (rest = []); + if rest <> [] then + error ~loc "Spilling cannot be applied"; let spills, fcall = spaux1 ctx fcall in let args = mkSpilled (List.rev vars) (missing_args_of !state loc modes types fcall) in @@ -1665,7 +1666,8 @@ end = struct (* {{{ *) let sp1, hd = spaux ctx hd in let sp2, tl = spaux ctx tl in (* FIXME: it could be in prop *) - assert(List.length hd = 1 && List.length tl = 1); + if not (List.length hd = 1 && List.length tl = 1) then + error ~loc "Spilling in a list, but I don't know if it is a list of props"; sp1 @ sp2, [Cons(List.hd hd, List.hd tl)] | Builtin(c,args) -> let spills, args = map_acc (fun sp x -> From f867d1830d2076df059a215e3e21a3032d0b4314 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 30 Apr 2020 10:00:09 +0200 Subject: [PATCH 2/3] Makefile: dune workspace for noppx test --- Makefile | 3 +++ dune-workspace.noppx | 2 ++ 2 files changed, 5 insertions(+) create mode 100644 dune-workspace.noppx diff --git a/Makefile b/Makefile index 2b6ccaad6..5ac1f14cd 100644 --- a/Makefile +++ b/Makefile @@ -56,6 +56,9 @@ tests: $(addprefix --name-match ,$(ONLY)) \ $(addprefix --runner , $(RUNNERS)) +test-noppx: + dune build --workspace dune-workspace.noppx + git/%: rm -rf "_build/git/elpi-$*" mkdir -p "_build/git/elpi-$*" diff --git a/dune-workspace.noppx b/dune-workspace.noppx new file mode 100644 index 000000000..a951a3fb0 --- /dev/null +++ b/dune-workspace.noppx @@ -0,0 +1,2 @@ +(lang dune 2.0) +(context (opam (switch 4.04.0))) ; here I don't have ppxlib \ No newline at end of file From 95fa267edc3b293db1a5849607a1e8905672ca9e Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 16:35:35 +0200 Subject: [PATCH 3/3] API: only one conversion type indexed by a context object --- CHANGES.md | 20 + Makefile | 2 +- src/.ppcache/API.ml | 883 ----------------------------- src/.ppcache/API.mli | 659 --------------------- src/.ppcache/builtin.ml | 0 src/.ppcache/builtin.mli | 56 ++ src/.ppcache/compiler.ml | 84 +-- src/.ppcache/compiler.mli | 8 +- src/.ppcache/data.ml | 699 ++++++++++------------- src/.ppcache/runtime_trace_off.ml | 222 +++----- src/.ppcache/runtime_trace_off.mli | 7 +- src/.ppcache/runtime_trace_on.ml | 222 +++----- src/.ppcache/runtime_trace_on.mli | 7 +- src/API.ml | 563 ++++++++++++------ src/API.mli | 552 ++++++++++-------- src/builtin.elpi | 65 ++- src/builtin.ml | 467 +++++++++------ src/builtin.mli | 22 +- src/builtin_map.elpi | 2 +- src/builtin_set.elpi | 2 +- src/compiler.ml | 47 +- src/compiler.mli | 2 +- src/data.ml | 338 ++++++----- src/dune | 6 +- src/elpi-checker.elpi | 3 +- src/merlinppx.ppx.ml | 2 +- src/runtime.ml | 122 ++-- src/runtime.mli | 7 +- 28 files changed, 1885 insertions(+), 3184 deletions(-) delete mode 100644 src/.ppcache/API.ml delete mode 100644 src/.ppcache/API.mli create mode 100644 src/.ppcache/builtin.ml create mode 100644 src/.ppcache/builtin.mli diff --git a/CHANGES.md b/CHANGES.md index f8fa9b530..4f7de9fcd 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,10 +1,30 @@ ## v1.11.0 UNRELEASED +- Stdlib: + - triple, quadruple and quintuple data types + - char builtin + +- API: + - `ContextualConversion` module is gone. + - `('a, #ctx as 'c) Conversion.t` is the only datatype describing the + conversion for type `'a` under a context `'c` which is a subclass of + the raw context `#ctx`. + - `('i, 'k, #ctx as 'c) Conversion.context` is a datatype describing + the conversion for context `'i` indexed in the host application with keys + `'k`. A context items conversion can depend on a context as well. + - `BuiltInData.nominal` for nominal constants. + - `PPX` sub module gathering private access points for the `elpi_ppx` deriver. + - Conversions for data types such as `diagnostic`, `bool`, `*_stream` + moved from `Elpi.Builtin` to `Elpi.API.BuiltInData`. + - Trace: - json output, with messages representing the tree structure of the proof - categorize spy points into `user` and `dev` - improve trace_ppx, revise all trace points - port to ppxlib + - commodity extension `[%elpi.template name args]` and + `let[@elpi.template] f = fun args -> code` attribute to perform + compile time inlining (can be used to circumvent the value restriction) - Build system: - cache ppx output so that it builds without ppx_deriving and trace_ppx diff --git a/Makefile b/Makefile index 5ac1f14cd..03939de28 100644 --- a/Makefile +++ b/Makefile @@ -29,7 +29,7 @@ DUNE_OPTS= build: dune build $(DUNE_OPTS) @all ; RC=$$?; \ ( cp -r _build/default/src/.ppcache src/ 2>/dev/null || true ); \ - ( echo "FLG -ppx './merlinppx.exe --as-ppx --trace_ppx-on'" >> src/.merlin );\ + ( echo "FLG -ppx './merlinppx.exe --as-ppx --cookie '\''elpi_trace=\"true\"'\'''" >> src/.merlin );\ exit $$RC install: diff --git a/src/.ppcache/API.ml b/src/.ppcache/API.ml deleted file mode 100644 index 77fb0156c..000000000 --- a/src/.ppcache/API.ml +++ /dev/null @@ -1,883 +0,0 @@ -(*2186ca58e78b30b2616c65e76db3513ad756c89d *src/API.ml *) -#1 "src/API.ml" -module type Runtime = module type of Runtime_trace_off -let r = ref ((module Runtime_trace_off) : (module Runtime)) -let set_runtime b = - (match b with - | true -> r := ((module Runtime_trace_on) : (module Runtime)) - | false -> r := ((module Runtime_trace_off) : (module Runtime))); - (let module R = (val !r) in - Util.set_spaghetti_printer Data.pp_const R.Pp.pp_constant) -let set_trace argv = - let args = Trace_ppx_runtime.Runtime.parse_argv argv in - set_runtime (!Trace_ppx_runtime.Runtime.debug); args -module Setup = - struct - type builtins = (string * Data.BuiltInPredicate.declaration list) - type elpi = (Parser.parser_state * Compiler.compilation_unit) - let init ~builtins ~basedir:cwd argv = - let new_argv = set_trace argv in - let (new_argv, paths) = - let rec aux args paths = - function - | [] -> ((List.rev args), (List.rev paths)) - | "-I"::p::rest -> aux args (p :: paths) rest - | x::rest -> aux (x :: args) paths rest in - aux [] [] new_argv in - let parsing_state = - Parser.init ~lp_syntax:Parser.lp_gramext ~paths ~cwd in - let state = Compiler.init_state Compiler.default_flags in - let state = - List.fold_left - (fun state -> - fun (_, decls) -> - List.fold_left - (fun state -> - function - | Data.BuiltInPredicate.MLCode (p, _) -> - Compiler.Builtins.register state p - | Data.BuiltInPredicate.MLData _ -> state - | Data.BuiltInPredicate.MLDataC _ -> state - | Data.BuiltInPredicate.LPCode _ -> state - | Data.BuiltInPredicate.LPDoc _ -> state) state decls) - state builtins in - let header = - builtins |> - (List.map - (fun (fname, decls) -> - let b = Buffer.create 1024 in - let fmt = Format.formatter_of_buffer b in - Data.BuiltInPredicate.document fmt decls; - Format.pp_print_flush fmt (); - (let text = Buffer.contents b in - let strm = Stream.of_string text in - let loc = Util.Loc.initial fname in - try - Parser.parse_program_from_stream parsing_state - ~print_accumulated_files:false loc strm - with - | Parser.ParseError (loc, msg) -> - (List.iteri - (fun i -> - fun s -> Printf.eprintf "%4d: %s\n" (i + 1) s) - (let open Re.Str in - split_delim (regexp_string "\n") text); - Printf.eprintf "Excerpt of %s:\n%s\n" fname - (String.sub text loc.Util.Loc.line_starts_at - (let open Util.Loc in - loc.source_stop - loc.line_starts_at)); - Util.anomaly ~loc msg)))) in - let header = - try Compiler.unit_of_ast state (List.concat header) - with | Compiler.CompileError (loc, msg) -> Util.anomaly ?loc msg in - ((parsing_state, header), new_argv) - let trace args = - match set_trace args with - | [] -> () - | l -> - Util.error - ("Elpi_API.trace got unknown arguments: " ^ (String.concat " " l)) - let usage = - "\nParsing options:\n" ^ - ("\t-I PATH search for accumulated files in PATH\n" ^ - Trace_ppx_runtime.Runtime.usage) - let set_warn = Util.set_warn - let set_error = Util.set_error - let set_anomaly = Util.set_anomaly - let set_type_error = Util.set_type_error - let set_std_formatter = Util.set_std_formatter - let set_err_formatter fmt = - Util.set_err_formatter fmt; - (let open Trace_ppx_runtime.Runtime in set_trace_output TTY fmt) - end -module EA = Ast -module Ast = - struct - type program = Ast.Program.t - type query = Ast.Goal.t - module Loc = Util.Loc - end -module Parse = - struct - let program ~elpi:(ps, _) ?(print_accumulated_files= false) = - Parser.parse_program ps ~print_accumulated_files - let program_from_stream ~elpi:(ps, _) ?(print_accumulated_files= false) - = Parser.parse_program_from_stream ps ~print_accumulated_files - let goal loc s = Parser.parse_goal ~loc s - let goal_from_stream loc s = Parser.parse_goal_from_stream ~loc s - exception ParseError = Parser.ParseError - end -module ED = Data -module Data = - struct - type term = Data.term - type constraints = Data.constraints - type state = Data.State.t - type pretty_printer_context = ED.pp_ctx - module StrMap = Util.StrMap - type 'a solution = 'a Data.solution = - { - assignments: term StrMap.t ; - constraints: constraints ; - state: state ; - output: 'a ; - pp_ctx: pretty_printer_context } - type hyp = Data.clause_src = { - hdepth: int ; - hsrc: term } - type hyps = hyp list - end -module Compile = - struct - type program = (ED.State.t * Compiler.program) - type 'a query = 'a Compiler.query - type 'a executable = 'a ED.executable - type compilation_unit = Compiler.compilation_unit - exception CompileError = Compiler.CompileError - let program ~flags ~elpi:(_, header) l = - Compiler.program_of_ast (Compiler.init_state flags) ~header - (List.flatten l) - let query (s, p) t = Compiler.query_of_ast s p t - let static_check ~checker q = - let module R = (val !r) in - let open R in - Compiler.static_check - ~exec:(execute_once ~delay_outside_fragment:false) ~checker q - module StrSet = Util.StrSet - type flags = Compiler.flags = - { - defined_variables: StrSet.t ; - print_passes: bool } - let default_flags = Compiler.default_flags - let optimize = Compiler.optimize_query - let unit ~elpi:(_, header) ~flags x = - Compiler.unit_of_ast (Compiler.init_state flags) ~header x - let assemble ~elpi:(_, header) = Compiler.assemble_units ~header - end -module Execute = - struct - type 'a outcome = 'a ED.outcome = - | Success of 'a Data.solution - | Failure - | NoMoreSteps - let once ?max_steps ?delay_outside_fragment p = - let module R = (val !r) in - R.execute_once ?max_steps ?delay_outside_fragment p - let loop ?delay_outside_fragment p ~more ~pp = - let module R = (val !r) in - R.execute_loop ?delay_outside_fragment p ~more ~pp - end -module Pp = - struct - let term pp_ctx f t = - let module R = (val !r) in - let open R in R.Pp.uppterm ~pp_ctx 0 [] 0 [||] f t - let constraints pp_ctx f c = - let module R = (val !r) in - let open R in - Util.pplist ~boxed:true (let open R in pp_stuck_goal ~pp_ctx) "" f - c - let state = ED.State.pp - let query f c = - let module R = (val !r) in - let open R in - Compiler.pp_query (fun ~depth -> R.Pp.uppterm depth [] 0 [||]) f c - module Ast = struct let program = EA.Program.pp end - end -module Conversion = - struct type extra_goals = ED.extra_goals - include ED.Conversion end -module ContextualConversion = ED.ContextualConversion -module RawOpaqueData = - struct - include Util.CData - include ED.C - type name = string - type doc = string - type 'a declaration = - { - name: name ; - doc: doc ; - pp: Format.formatter -> 'a -> unit ; - compare: 'a -> 'a -> int ; - hash: 'a -> int ; - hconsed: bool ; - constants: (name * 'a) list } - let conversion_of_cdata ~name ?(doc= "") ~constants_map ~constants - { cin; isc; cout; name = c } = - let ty = Conversion.TyName name in - let embed ~depth:_ state x = (state, (ED.Term.CData (cin x)), []) in - let readback ~depth state t = - let module R = (val !r) in - let open R in - match R.deref_head ~depth t with - | ED.Term.CData c when isc c -> (state, (cout c), []) - | ED.Term.Const i as t when i < 0 -> - (try (state, (ED.Constants.Map.find i constants_map), []) - with - | Not_found -> raise (Conversion.TypeErr (ty, depth, t))) - | t -> raise (Conversion.TypeErr (ty, depth, t)) in - let pp_doc fmt () = - let module R = (val !r) in - let open R in - if doc <> "" - then - (ED.BuiltInPredicate.pp_comment fmt ("% " ^ doc); - Format.fprintf fmt "@\n"); - Format.fprintf fmt - "@[typeabbrev %s (ctype \"%s\").@]@\n@\n" name c; - List.iter - (fun (c, _) -> - Format.fprintf fmt "@[type %s %s.@]@\n" c name) - constants in - { - Conversion.embed = embed; - readback; - ty; - pp_doc; - pp = (fun fmt -> fun x -> pp fmt (cin x)) - } - let conversion_of_cdata ~name ?doc ?(constants= []) cd = - let module R = (val !r) in - let open R in - let constants_map = - List.fold_right - (fun (n, v) -> - ED.Constants.Map.add - (ED.Global_symbols.declare_global_symbol n) v) constants - ED.Constants.Map.empty in - conversion_of_cdata ~name ?doc ~constants_map ~constants cd - let declare { name; doc; pp; compare; hash; hconsed; constants } = - let cdata = - declare - { - data_compare = compare; - data_pp = pp; - data_hash = hash; - data_name = name; - data_hconsed = hconsed - } in - (cdata, (conversion_of_cdata ~name ~doc ~constants cdata)) - end -module OpaqueData = - struct - type name = string - type doc = string - type 'a declaration = 'a RawOpaqueData.declaration = - { - name: name ; - doc: doc ; - pp: Format.formatter -> 'a -> unit ; - compare: 'a -> 'a -> int ; - hash: 'a -> int ; - hconsed: bool ; - constants: (name * 'a) list } - let declare x = snd @@ (RawOpaqueData.declare x) - end -module BuiltInData = - struct - let int = RawOpaqueData.conversion_of_cdata ~name:"int" ED.C.int - let float = RawOpaqueData.conversion_of_cdata ~name:"float" ED.C.float - let string = RawOpaqueData.conversion_of_cdata ~name:"string" ED.C.string - let loc = RawOpaqueData.conversion_of_cdata ~name:"loc" ED.C.loc - let poly ty = - let embed ~depth:_ state x = (state, x, []) in - let readback ~depth state t = (state, t, []) in - { - Conversion.embed = embed; - readback; - ty = (Conversion.TyName ty); - pp = (fun fmt -> fun _ -> Format.fprintf fmt ""); - pp_doc = (fun fmt -> fun () -> ()) - } - let any = poly "any" - let fresh_copy t depth = - let module R = (val !r) in - let open R in - let open ED in - let rec aux d t = - match deref_head ~depth:(depth + d) t with - | Lam t -> mkLam (aux (d + 1) t) - | Const c as x -> - if (c < 0) || (c >= depth) - then x - else - raise - (let open Conversion in - TypeErr ((TyName "closed term"), (depth + d), x)) - | App (c, x, xs) -> - if (c < 0) || (c >= depth) - then mkApp c (aux d x) (List.map (aux d) xs) - else - raise - (let open Conversion in - TypeErr ((TyName "closed term"), (depth + d), x)) - | UVar _|AppUVar _ as x -> - raise - (let open Conversion in - TypeErr ((TyName "closed term"), (depth + d), x)) - | Arg _|AppArg _ -> assert false - | Builtin (c, xs) -> mkBuiltin c (List.map (aux d) xs) - | CData _ as x -> x - | Cons (hd, tl) -> mkCons (aux d hd) (aux d tl) - | Nil as x -> x - | Discard as x -> x in - ((aux 0 t), depth) - let closed ty = - let ty = let open Conversion in TyName ty in - let embed ~depth state (x, from) = - let module R = (val !r) in - let open R in (state, (R.hmove ~from ~to_:depth ?avoid:None x), []) in - let readback ~depth state t = (state, (fresh_copy t depth), []) in - { - Conversion.embed = embed; - readback; - ty; - pp = - (fun fmt -> - fun (t, d) -> - let module R = (val !r) in - let open R in R.Pp.uppterm d [] d ED.empty_env fmt t); - pp_doc = (fun fmt -> fun () -> ()) - } - let map_acc f s l = - let rec aux acc extra s = - function - | [] -> (s, (List.rev acc), (let open List in concat (rev extra))) - | x::xs -> - let (s, x, gls) = f s x in aux (x :: acc) (gls :: extra) s xs in - aux [] [] s l - let listC d = - let embed ~depth h c s l = - let module R = (val !r) in - let open R in - let (s, l, eg) = - map_acc (d.ContextualConversion.embed ~depth h c) s l in - (s, (list_to_lp_list l), eg) in - let readback ~depth h c s t = - let module R = (val !r) in - let open R in - map_acc (d.ContextualConversion.readback ~depth h c) s - (lp_list_to_list ~depth t) in - let pp fmt l = - Format.fprintf fmt "[%a]" (Util.pplist d.pp ~boxed:true "; ") l in - { - ContextualConversion.embed = embed; - readback; - ty = (TyApp ("list", (d.ty), [])); - pp; - pp_doc = (fun fmt -> fun () -> ()) - } - let list d = - let embed ~depth s l = - let module R = (val !r) in - let open R in - let (s, l, eg) = map_acc (d.Conversion.embed ~depth) s l in - (s, (list_to_lp_list l), eg) in - let readback ~depth s t = - let module R = (val !r) in - let open R in - map_acc (d.Conversion.readback ~depth) s - (lp_list_to_list ~depth t) in - let pp fmt l = - Format.fprintf fmt "[%a]" (Util.pplist d.pp ~boxed:true "; ") l in - { - Conversion.embed = embed; - readback; - ty = (TyApp ("list", (d.ty), [])); - pp; - pp_doc = (fun fmt -> fun () -> ()) - } - end -module Elpi = - struct - type t = - | Arg of string - | Ref of ED.uvar_body - let pp fmt handle = - match handle with - | Arg str -> Format.fprintf fmt "%s" str - | Ref ub -> - let module R = (val !r) in - let open R in R.Pp.uppterm 0 [] 0 [||] fmt (ED.mkUVar ub 0 0) - let show m = Format.asprintf "%a" pp m - let equal h1 h2 = - match (h1, h2) with - | (Ref p1, Ref p2) -> p1 == p2 - | (Arg s1, Arg s2) -> String.equal s1 s2 - | _ -> false - let compilation_is_over ~args k = - match k with - | Ref _ -> assert false - | Arg s -> Ref (Util.StrMap.find s args) - let uvk = - ED.State.declare ~name:"elpi:uvk" ~pp:(Util.StrMap.pp pp) - ~clause_compilation_is_over:(fun x -> Util.StrMap.empty) - ~goal_compilation_is_over:(fun ~args -> - fun x -> - Some - (Util.StrMap.map - (compilation_is_over ~args) x)) - ~compilation_is_over:(fun _ -> None) - ~execution_is_over:(fun _ -> None) - ~init:(fun () -> Util.StrMap.empty) - let fresh_name = - let i = ref 0 in fun () -> incr i; Printf.sprintf "_uvk_%d_" (!i) - let alloc_Elpi name state = - if ED.State.get ED.while_compiling state - then - let (state, _arg) = Compiler.mk_Arg ~name ~args:[] state in - (state, (Arg name)) - else (let module R = (val !r) in (state, (Ref (ED.oref ED.dummy)))) - let make ?name state = - match name with - | None -> alloc_Elpi (fresh_name ()) state - | Some name -> - (try (state, (Util.StrMap.find name (ED.State.get uvk state))) - with - | Not_found -> - let (state, k) = alloc_Elpi name state in - ((ED.State.update uvk state (Util.StrMap.add name k)), k)) - let get ~name state = - try Some (Util.StrMap.find name (ED.State.get uvk state)) - with | Not_found -> None - end -module RawData = - struct - type constant = ED.Term.constant - type builtin = ED.Term.constant - type uvar_body = ED.Term.uvar_body - type term = ED.Term.term - type view = - | Const of constant - | Lam of term - | App of constant * term * term list - | Cons of term * term - | Nil - | Builtin of builtin * term list - | CData of RawOpaqueData.t - | UnifVar of Elpi.t * term list - let rec look ~depth t = - let module R = (val !r) in - let open R in - match R.deref_head ~depth t with - | ED.Term.Arg _|ED.Term.AppArg _ -> assert false - | ED.Term.AppUVar (ub, 0, args) -> UnifVar ((Ref ub), args) - | ED.Term.AppUVar (ub, lvl, args) -> - look ~depth (R.expand_appuv ub ~depth ~lvl ~args) - | ED.Term.UVar (ub, lvl, ano) -> - look ~depth (R.expand_uv ub ~depth ~lvl ~ano) - | ED.Term.Discard -> - let ub = ED.oref ED.dummy in - UnifVar ((Ref ub), (R.mkinterval 0 depth 0)) - | x -> Obj.magic x - let kool = - function - | UnifVar (Ref ub, args) -> ED.Term.AppUVar (ub, 0, args) - | UnifVar (Arg _, _) -> assert false - | x -> Obj.magic x[@@inline ] - let mkConst n = let module R = (val !r) in R.mkConst n - let mkLam = ED.Term.mkLam - let mkApp = ED.Term.mkApp - let mkCons = ED.Term.mkCons - let mkNil = ED.Term.mkNil - let mkDiscard = ED.Term.mkDiscard - let mkBuiltin = ED.Term.mkBuiltin - let mkCData = ED.Term.mkCData - let mkAppL x l = let module R = (val !r) in R.mkAppL x l - let mkGlobal i = - if i >= 0 then Util.anomaly "mkGlobal: got a bound variable"; mkConst i - let mkBound i = - if i < 0 then Util.anomaly "mkBound: got a global constant"; mkConst i - let cmp_builtin i j = i - j - module Constants = - struct - let declare_global_symbol = ED.Global_symbols.declare_global_symbol - let show c = ED.Constants.show c - let eqc = ED.Global_symbols.eqc - let orc = ED.Global_symbols.orc - let andc = ED.Global_symbols.andc - let rimplc = ED.Global_symbols.rimplc - let pic = ED.Global_symbols.pic - let sigmac = ED.Global_symbols.sigmac - let implc = ED.Global_symbols.implc - let cutc = ED.Global_symbols.cutc - let ctypec = ED.Global_symbols.ctypec - let spillc = ED.Global_symbols.spillc - module Map = ED.Constants.Map - module Set = ED.Constants.Set - end - let of_term x = x - let of_hyps x = x - type hyp = Data.hyp = { - hdepth: int ; - hsrc: term } - type hyps = hyp list - type suspended_goal = ED.suspended_goal = - { - context: hyps ; - goal: (int * term) } - type constraints = Data.constraints - let constraints l = - let module R = (val !r) in - let open R in - Util.map_filter (fun x -> R.get_suspended_goal x.ED.kind) l - let no_constraints = [] - let mkUnifVar handle ~args state = - match handle with - | Elpi.Ref ub -> ED.Term.mkAppUVar ub 0 args - | Elpi.Arg name -> Compiler.get_Arg state ~name ~args - end -module FlexibleData = - struct - module Elpi = Elpi - module type Host = - sig - type t - val compare : t -> t -> int - val pp : Format.formatter -> t -> unit - val show : t -> string - end - let uvmap_no = ref 0 - module Map(T:Host) = - struct - open Util - module H2E = (Map.Make)(T) - type t = - { - h2e: Elpi.t H2E.t ; - e2h_compile: T.t StrMap.t ; - e2h_run: T.t PtrMap.t } - let empty = - { - h2e = H2E.empty; - e2h_compile = StrMap.empty; - e2h_run = (PtrMap.empty ()) - } - let add uv v { h2e; e2h_compile; e2h_run } = - let h2e = H2E.add v uv h2e in - match uv with - | Elpi.Ref ub -> - { h2e; e2h_compile; e2h_run = (PtrMap.add ub v e2h_run) } - | Arg s -> - { h2e; e2h_run; e2h_compile = (StrMap.add s v e2h_compile) } - let elpi v { h2e } = H2E.find v h2e - let host handle { e2h_compile; e2h_run } = - match handle with - | Elpi.Ref ub -> PtrMap.find ub e2h_run - | Arg s -> StrMap.find s e2h_compile - let remove_both handle v { h2e; e2h_compile; e2h_run } = - let h2e = H2E.remove v h2e in - match handle with - | Elpi.Ref ub -> - { h2e; e2h_compile; e2h_run = (PtrMap.remove ub e2h_run) } - | Arg s -> - { h2e; e2h_run; e2h_compile = (StrMap.remove s e2h_compile) } - let remove_elpi k m = let v = host k m in remove_both k v m - let remove_host v m = let handle = elpi v m in remove_both handle v m - let filter f { h2e; e2h_compile; e2h_run } = - let e2h_compile = - StrMap.filter (fun n -> fun v -> f v (H2E.find v h2e)) - e2h_compile in - let e2h_run = - PtrMap.filter (fun ub -> fun v -> f v (H2E.find v h2e)) e2h_run in - let h2e = H2E.filter f h2e in { h2e; e2h_compile; e2h_run } - let fold f { h2e } acc = - let module R = (val !r) in - let open R in - let get_val = - function - | Elpi.Ref { ED.Term.contents = ub } when ub != ED.dummy -> - Some (R.deref_head ~depth:0 ub) - | Elpi.Ref _ -> None - | Elpi.Arg _ -> None in - H2E.fold - (fun k -> fun uk -> fun acc -> f k uk (get_val uk) acc) h2e - acc - let uvn = incr uvmap_no; !uvmap_no - let pp fmt (m : t) = - let pp k uv _ () = - Format.fprintf fmt "@[%a@ <-> %a@]@ " T.pp k Elpi.pp uv in - Format.fprintf fmt "@["; fold pp m (); Format.fprintf fmt "@]" - let show m = Format.asprintf "%a" pp m - let uvmap = - ED.State.declare ~name:(Printf.sprintf "elpi:uvm:%d" uvn) ~pp - ~clause_compilation_is_over:(fun x -> empty) - ~goal_compilation_is_over:(fun ~args -> - fun { h2e; e2h_compile; e2h_run } -> - let h2e = - H2E.map - (Elpi.compilation_is_over - ~args) h2e in - let e2h_run = - StrMap.fold - (fun k -> - fun v -> - fun m -> - PtrMap.add - (StrMap.find k args) - v m) e2h_compile - (PtrMap.empty ()) in - Some - { - h2e; - e2h_compile = StrMap.empty; - e2h_run - }) - ~compilation_is_over:(fun x -> Some x) - ~execution_is_over:(fun x -> Some x) ~init:(fun () -> empty) - end - let uvar = - { - Conversion.ty = (Conversion.TyName "uvar"); - pp_doc = - (fun fmt -> - fun () -> - Format.fprintf fmt "Unification variable, as the uvar keyword"); - pp = (fun fmt -> fun (k, _) -> Format.fprintf fmt "%a" Elpi.pp k); - embed = - (fun ~depth -> - fun s -> fun (k, args) -> (s, (RawData.mkUnifVar k ~args s), [])); - readback = - (fun ~depth -> - fun state -> - fun t -> - match RawData.look ~depth t with - | RawData.UnifVar (k, args) -> (state, (k, args), []) - | _ -> - raise (Conversion.TypeErr ((TyName "uvar"), depth, t))) - } - end -module AlgebraicData = - struct - include ED.BuiltInPredicate.ADT - type name = string - type doc = string - let declare x = - let module R = (val !r) in - ED.BuiltInPredicate.ADT.adt ~look:R.deref_head - ~mkinterval:R.mkinterval ~mkConst:R.mkConst - ~alloc:FlexibleData.Elpi.make ~mkUnifVar:RawData.mkUnifVar x - end -module BuiltInPredicate = - struct - include ED.BuiltInPredicate - exception No_clause = ED.No_clause - let mkData x = Data x - let ioargC a = - let open ContextualConversion in - { - a with - pp = - (fun fmt -> - function - | Data x -> a.pp fmt x - | NoData -> Format.fprintf fmt "_"); - embed = - (fun ~depth -> - fun hyps -> - fun csts -> - fun state -> - function - | Data x -> a.embed ~depth hyps csts state x - | NoData -> assert false); - readback = - (fun ~depth -> - fun hyps -> - fun csts -> - fun state -> - fun t -> - let module R = (val !r) in - let open R in - match R.deref_head ~depth t with - | ED.Term.Arg _|ED.Term.AppArg _ -> assert false - | ED.Term.UVar _|ED.Term.AppUVar _|ED.Term.Discard - -> (state, NoData, []) - | _ -> - let (state, x, gls) = - a.readback ~depth hyps csts state t in - (state, (mkData x), gls)) - } - let ioarg a = let open ContextualConversion in !< (ioargC (!> a)) - let ioarg_any = - let open Conversion in - { - BuiltInData.any with - pp = - (fun fmt -> - function - | Data x -> BuiltInData.any.pp fmt x - | NoData -> Format.fprintf fmt "_"); - embed = - (fun ~depth -> - fun state -> - function | Data x -> (state, x, []) | NoData -> assert false); - readback = - (fun ~depth -> - fun state -> - fun t -> - let module R = (val !r) in - match R.deref_head ~depth t with - | ED.Term.Discard -> (state, NoData, []) - | _ -> (state, (Data t), [])) - } - module Notation = - struct - let (!:) x = ((), (Some x)) - let (+!) a b = (a, (Some b)) - let (?:) x = ((), x) - let (+?) a b = (a, b) - end - end -module BuiltIn = - struct - include ED.BuiltInPredicate - let declare ~file_name l = (file_name, l) - let document_fmt fmt (_, l) = ED.BuiltInPredicate.document fmt l - let document_file ?(header= "") (name, l) = - let oc = open_out name in - let fmt = Format.formatter_of_out_channel oc in - Format.fprintf fmt "%s%!" header; - ED.BuiltInPredicate.document fmt l; - Format.pp_print_flush fmt (); - close_out oc - end -module Query = - struct - type name = string - type 'f arguments = 'f ED.Query.arguments = - | N: unit arguments - | D: 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q: 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments - type 'x t = - | Query of { - predicate: name ; - arguments: 'x arguments } - let compile (state, p) loc (Query { predicate; arguments }) = - let (state, predicate) = - Compiler.Symbols.allocate_global_symbol_str state predicate in - let q = ED.Query.Query { predicate; arguments } in - Compiler.query_of_data state p loc q - end -module State = - struct - include ED.State - let declare ~name ~pp ~init = - declare ~name ~pp ~init ~clause_compilation_is_over:(fun x -> x) - ~goal_compilation_is_over:(fun ~args:_ -> fun x -> Some x) - ~compilation_is_over:(fun x -> Some x) - ~execution_is_over:(fun x -> Some x) - end -module RawQuery = - struct - let mk_Arg = Compiler.mk_Arg - let is_Arg = Compiler.is_Arg - let compile (state, p) f = Compiler.query_of_term state p f - end -module Quotation = - struct - include Compiler - let declare_backtick ~name f = - Compiler.CustomFunctorCompilation.declare_backtick_compilation name - (fun s -> fun x -> f s (EA.Func.show x)) - let declare_singlequote ~name f = - Compiler.CustomFunctorCompilation.declare_singlequote_compilation name - (fun s -> fun x -> f s (EA.Func.show x)) - let term_at ~depth s x = Compiler.term_of_ast ~depth s x - let quote_syntax_runtime s q = - let module R = (val !r) in - Compiler.quote_syntax (`Runtime R.mkConst) s q - let quote_syntax_compiletime s q = - let (s, l, t) = Compiler.quote_syntax `Compiletime s q in (s, l, t) - end -module Utils = - struct - let lp_list_to_list ~depth t = - let module R = (val !r) in let open R in lp_list_to_list ~depth t - let list_to_lp_list tl = - let module R = (val !r) in let open R in list_to_lp_list tl - let get_assignment = - function - | Elpi.Arg _ -> assert false - | Elpi.Ref { ED.contents = t } -> - let module R = (val !r) in if t == ED.dummy then None else Some t - let move ~from ~to_ t = - let module R = (val !r) in - let open R in R.hmove ~from ~to_ ?avoid:None t - let beta ~depth t args = - let module R = (val !r) in - let open R in R.deref_appuv ~from:depth ~to_:depth ?avoid:None args t - let error = Util.error - let type_error = Util.type_error - let anomaly = Util.anomaly - let warn = Util.warn - let clause_of_term ?name ?graft ~depth loc term = - let open EA in - let module Data = ED.Term in - let module R = (val !r) in - let open R in - let rec aux d ctx t = - match R.deref_head ~depth:d t with - | Data.Const i when (i >= 0) && (i < depth) -> - error "program_of_term: the term is not closed" - | Data.Const i when i < 0 -> Term.mkCon (ED.Constants.show i) - | Data.Const i -> Util.IntMap.find i ctx - | Data.Lam t -> - let s = "x" ^ (string_of_int d) in - let ctx = Util.IntMap.add d (Term.mkCon s) ctx in - Term.mkLam s (aux (d + 1) ctx t) - | Data.App (c, x, xs) -> - let c = aux d ctx (R.mkConst c) in - let x = aux d ctx x in - let xs = List.map (aux d ctx) xs in - Term.mkApp loc (c :: x :: xs) - | Data.Arg _|Data.AppArg _ -> assert false - | Data.Cons (hd, tl) -> - let hd = aux d ctx hd in - let tl = aux d ctx tl in Term.mkSeq [hd; tl] - | Data.Nil -> Term.mkNil - | Data.Builtin (c, xs) -> - let c = aux d ctx (R.mkConst c) in - let xs = List.map (aux d ctx) xs in - Term.mkApp loc (c :: xs) - | Data.CData x -> Term.mkC x - | Data.UVar _|Data.AppUVar _ -> - error "program_of_term: the term contains uvars" - | Data.Discard -> Term.mkCon "_" in - let attributes = - (match name with | Some x -> [Clause.Name x] | None -> []) @ - (match graft with - | Some (`After, x) -> [Clause.After x] - | Some (`Before, x) -> [Clause.Before x] - | None -> []) in - [Program.Clause - { - Clause.loc = loc; - attributes; - body = (aux depth Util.IntMap.empty term) - }] - let map_acc = BuiltInData.map_acc - module type Show = Util.Show - module type Show1 = Util.Show1 - module Map = Util.Map - module Set = Util.Set - end -module RawPp = - struct - let term depth fmt t = - let module R = (val !r) in - let open R in R.Pp.uppterm depth [] 0 ED.empty_env fmt t - let constraints f c = - let module R = (val !r) in - let open R in - Util.pplist ~boxed:true (R.pp_stuck_goal ?pp_ctx:None) "" f c - let list = Util.pplist - module Debug = - struct - let term depth fmt t = - let module R = (val !r) in - let open R in R.Pp.ppterm depth [] 0 ED.empty_env fmt t - let show_term = ED.show_term - end - end - diff --git a/src/.ppcache/API.mli b/src/.ppcache/API.mli deleted file mode 100644 index c1ae9a0a4..000000000 --- a/src/.ppcache/API.mli +++ /dev/null @@ -1,659 +0,0 @@ -(*927d066a4a64bd8ebdf616cca09a2e6c6b896a27 *src/API.mli *) -#1 "src/API.mli" -[@@@ocaml.text " This module is the API for clients of the Elpi library. "] -[@@@ocaml.text - " These APIs are sufficient to parse programs and queries from text, run\n the interpreter and finally print the result "] -module Ast : -sig - type program - type query - module Loc : - sig - type t = - { - source_name: string ; - source_start: int ; - source_stop: int ; - line: int ; - line_starts_at: int } - val pp : Format.formatter -> t -> unit - val show : t -> string - val equal : t -> t -> bool - val compare : t -> t -> int - val initial : string -> t - end -end -module Setup : -sig - type builtins - type elpi - val init : - builtins:builtins list -> - basedir:string -> string list -> (elpi * string list)[@@ocaml.doc - " Initialize ELPI.\n [init] must be called before invoking the parser.\n [builtins] the set of built-in predicates, eg [Elpi_builtin.std_builtins]\n [basedir] current working directory (used to make paths absolute);\n [argv] is list of options, see the {!val:usage} string;\n It returns part of [argv] not relevant to ELPI and a handle [elpi]\n to an elpi instance equipped with the given builtins. "] - val usage : string[@@ocaml.doc " Usage string "] - val trace : string list -> unit[@@ocaml.doc - " Set tracing options.\n [trace argv] can be called before {!module:Execute}.\n [argv] is expected to only contain options relevant for\n the tracing facility. "] - val set_warn : (?loc:Ast.Loc.t -> string -> unit) -> unit[@@ocaml.doc - " Override default runtime error functions (they call exit) "] - val set_error : (?loc:Ast.Loc.t -> string -> 'a) -> unit - val set_anomaly : (?loc:Ast.Loc.t -> string -> 'a) -> unit - val set_type_error : (?loc:Ast.Loc.t -> string -> 'a) -> unit - val set_std_formatter : Format.formatter -> unit - val set_err_formatter : Format.formatter -> unit -end -module Parse : -sig - val program : - elpi:Setup.elpi -> - ?print_accumulated_files:bool -> string list -> Ast.program[@@ocaml.doc - " [program file_list] parses a list of files "] - val program_from_stream : - elpi:Setup.elpi -> - ?print_accumulated_files:bool -> - Ast.Loc.t -> char Stream.t -> Ast.program - val goal : Ast.Loc.t -> string -> Ast.query[@@ocaml.doc - " [goal file_list] parses the query "] - val goal_from_stream : Ast.Loc.t -> char Stream.t -> Ast.query - exception ParseError of Ast.Loc.t * string -end -module Data : -sig - module StrMap : - sig - include Map.S with type key = string - val show : (Format.formatter -> 'a -> unit) -> 'a t -> string - val pp : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - end - type term - type constraints - type state - type pretty_printer_context - type 'a solution = - { - assignments: term StrMap.t ; - constraints: constraints ; - state: state ; - output: 'a ; - pp_ctx: pretty_printer_context } - type hyp - type hyps = hyp list -end -module Compile : -sig - module StrSet : - sig - include Set.S with type elt = string - val show : t -> string - val pp : Format.formatter -> t -> unit - end - type flags = { - defined_variables: StrSet.t ; - print_passes: bool } - val default_flags : flags - type program - type 'a query - type 'a executable - exception CompileError of Ast.Loc.t option * string - val program : flags:flags -> elpi:Setup.elpi -> Ast.program list -> program - type compilation_unit - val unit : - elpi:Setup.elpi -> flags:flags -> Ast.program -> compilation_unit - val assemble : elpi:Setup.elpi -> compilation_unit list -> program - val query : program -> Ast.query -> unit query - val optimize : 'a query -> 'a executable - val static_check : checker:program -> 'a query -> bool[@@ocaml.doc - " Runs a checker. Returns true if no errors were found.\n See also Builtins.default_checker. "] -end -module Execute : -sig - type 'a outcome = - | Success of 'a Data.solution - | Failure - | NoMoreSteps - val once : - ?max_steps:int -> - ?delay_outside_fragment:bool -> 'a Compile.executable -> 'a outcome - val loop : - ?delay_outside_fragment:bool -> - 'a Compile.executable -> - more:(unit -> bool) -> pp:(float -> 'a outcome -> unit) -> unit - [@@ocaml.doc - " Prolog's REPL.\n [pp] is called on all solutions.\n [more] is called to know if another solution has to be searched for. "] -end -module Pp : -sig - val term : - Data.pretty_printer_context -> Format.formatter -> Data.term -> unit - val constraints : - Data.pretty_printer_context -> - Format.formatter -> Data.constraints -> unit - val state : Format.formatter -> Data.state -> unit - val query : Format.formatter -> 'a Compile.query -> unit - module Ast : sig val program : Format.formatter -> Ast.program -> unit end -end -[@@@ocaml.text - " This API lets one exchange with the host application opaque (primitive)\n data such as integers or strings as well as algebraic data such OCaml's\n ADS. No support for binders or unification variables at thil point. "] -module Conversion : -sig - type ty_ast = - | TyName of string - | TyApp of string * ty_ast * ty_ast list - type extra_goals = Data.term list - type 'a embedding = - depth:int -> Data.state -> 'a -> (Data.state * Data.term * extra_goals) - type 'a readback = - depth:int -> Data.state -> Data.term -> (Data.state * 'a * extra_goals) - type 'a t = - { - ty: ty_ast ; - pp_doc: Format.formatter -> unit -> unit ; - pp: Format.formatter -> 'a -> unit ; - embed: 'a embedding ; - readback: 'a readback } - exception TypeErr of ty_ast * int * Data.term -end[@@ocaml.doc - " This module defines what embedding and readback functions are "] -module ContextualConversion : -sig - type ty_ast = Conversion.ty_ast = - | TyName of string - | TyApp of string * ty_ast * ty_ast list - type ('a, 'hyps, 'constraints) embedding = - depth:int -> - 'hyps -> - 'constraints -> - Data.state -> - 'a -> (Data.state * Data.term * Conversion.extra_goals) - type ('a, 'hyps, 'constraints) readback = - depth:int -> - 'hyps -> - 'constraints -> - Data.state -> - Data.term -> (Data.state * 'a * Conversion.extra_goals) - type ('a, 'h, 'c) t = - { - ty: ty_ast ; - pp_doc: Format.formatter -> unit -> unit ; - pp: Format.formatter -> 'a -> unit ; - embed: ('a, 'h, 'c) embedding ; - readback: ('a, 'h, 'c) readback } - type ('hyps, 'constraints) ctx_readback = - depth:int -> - Data.hyps -> - Data.constraints -> - Data.state -> - (Data.state * 'hyps * 'constraints * Conversion.extra_goals) - val unit_ctx : (unit, unit) ctx_readback - val raw_ctx : (Data.hyps, Data.constraints) ctx_readback - val (!<) : ('a, unit, unit) t -> 'a Conversion.t - val (!>) : 'a Conversion.t -> ('a, 'hyps, 'constraints) t - val (!>>) : - ('a Conversion.t -> 'b Conversion.t) -> - ('a, 'hyps, 'constraints) t -> ('b, 'hyps, 'constraints) t - val (!>>>) : - ('a Conversion.t -> 'b Conversion.t -> 'c Conversion.t) -> - ('a, 'hyps, 'constraints) t -> - ('b, 'hyps, 'constraints) t -> ('c, 'hyps, 'constraints) t -end[@@ocaml.doc - " This module defines what embedding and readback functions are\n for datatypes that need the context of the program (hypothetical clauses and\n constraints) "] -module BuiltInData : -sig - val int : int Conversion.t[@@ocaml.doc " See Elpi_builtin for a few more "] - val float : float Conversion.t - val string : string Conversion.t - val list : 'a Conversion.t -> 'a list Conversion.t - val loc : Ast.Loc.t Conversion.t - val poly : string -> Data.term Conversion.t - val closed : string -> (Data.term * int) Conversion.t - val any : Data.term Conversion.t -end[@@ocaml.doc " Conversion for Elpi's built-in data types "] -module OpaqueData : -sig - type doc = string - type name = string - type 'a declaration = - { - name: name ; - doc: doc ; - pp: Format.formatter -> 'a -> unit ; - compare: 'a -> 'a -> int ; - hash: 'a -> int ; - hconsed: bool ; - constants: (name * 'a) list }[@@ocaml.doc - " The [eq] function is used by unification. Limitation: unification of\n * two cdata cannot alter the constraint store. This can be lifted in the\n * future if there is user request.\n *\n * If the hconsed is true, then the [readback] function is\n * automatically hashcons the data using the [eq] and [hash] functions.\n "] - val declare : 'a declaration -> 'a Conversion.t -end[@@ocaml.doc - " Declare data from the host application that is opaque (no syntax), like\n int but not like list or pair "] -module AlgebraicData : -sig - type name = string - type doc = string - type ('match_stateful_t, 'match_t, 't) match_t = - | M of (ok:'match_t -> ko:(unit -> Data.term) -> 't -> Data.term) - | MS of - (ok:'match_stateful_t -> - ko:(Data.state -> (Data.state * Data.term * Conversion.extra_goals)) - -> - 't -> - Data.state -> (Data.state * Data.term * Conversion.extra_goals)) - - type ('build_stateful_t, 'build_t) build_t = - | B of 'build_t - | BS of 'build_stateful_t - type ('stateful_builder, 'builder, 'stateful_matcher, 'matcher, 'self, - 'hyps, 'constraints) constructor_arguments = - | N: (Data.state -> (Data.state * 'self), 'self, - Data.state -> (Data.state * Data.term * Conversion.extra_goals), - Data.term, 'self, 'hyps, 'constraints) constructor_arguments - | A: 'a Conversion.t * ('bs, 'b, 'ms, 'm, 'self, 'hyps, 'constraints) - constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, - 'self, 'hyps, 'constraints) constructor_arguments - | CA: ('a, 'hyps, 'constraints) ContextualConversion.t * ('bs, 'b, - 'ms, 'm, 'self, 'hyps, 'constraints) constructor_arguments -> ('a -> 'bs, - 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps, 'constraints) - constructor_arguments - | S: ('bs, 'b, 'ms, 'm, 'self, 'hyps, 'constraints) constructor_arguments - -> ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, - 'hyps, 'constraints) constructor_arguments - | C: - (('self, 'hyps, 'constraints) ContextualConversion.t -> - ('a, 'hyps, 'constraints) ContextualConversion.t) - * ('bs, 'b, 'ms, 'm, 'self, 'hyps, 'constraints) constructor_arguments -> - ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps, 'constraints) - constructor_arguments [@@ocaml.doc - " GADT for describing the type of the constructor:\n - N is the terminator\n - A(a,...) is an argument of type a (a is a Conversion.t)\n - S stands for self\n - C stands for container\n "] - type ('t, 'h, 'c) constructor = - | K: name * doc * ('build_stateful_t, 'build_t, 'match_stateful_t, - 'match_t, 't, 'h, 'c) constructor_arguments * ('build_stateful_t, - 'build_t) build_t * ('match_stateful_t, 'match_t, 't) match_t -> ( - 't, 'h, 'c) constructor - type ('t, 'h, 'c) declaration = - { - ty: Conversion.ty_ast ; - doc: doc ; - pp: Format.formatter -> 't -> unit ; - constructors: ('t, 'h, 'c) constructor list } - val declare : - ('t, 'h, 'c) declaration -> ('t, 'h, 'c) ContextualConversion.t -end[@@ocaml.doc - " Declare data from the host application that has syntax, like\n list or pair but not like int. So far there is no support for\n data with binder using this API. The type of each constructor is\n described using a GADT so that the code to build or match the data\n can be given the right type. Example: define the ADT for \"option a\"\n{[\n let option_declaration a = {\n ty = TyApp(\"option\",a.ty,[]);\n doc = \"The option type (aka Maybe)\";\n pp = (fun fmt -> function\n | None -> Format.fprintf fmt \"None\"\n | Some x -> Format.fprintf fmt \"Some %a\" a.pp x);\n constructors = [\n K(\"none\",\"nothing in this case\",\n N, (* no arguments *)\n B None, (* builder *)\n M (fun ~ok ~ko -> function None -> ok | _ -> ko ())); (* matcher *)\n K(\"some\",\"something in this case\",\n A (a,N), (* one argument of type a *)\n B (fun x -> Some x), (* builder *)\n M (fun ~ok ~ko -> function Some x -> ok x | _ -> ko ())); (* matcher *)\n ]\n }\n\n ]}\n\n [K] stands for \"constructor\", [B] for \"build\", [M] for \"match\".\n Variants [BS] and [MS] give read/write access to the state.\n\n"] -module BuiltInPredicate : -sig - exception No_clause - type name = string - type doc = string - type 'a oarg = - | Keep - | Discard - type 'a ioarg = private - | Data of 'a - | NoData - type ('function_type, 'inernal_outtype_in, 'internal_hyps, - 'internal_constraints) ffi = - | In: 't Conversion.t * doc * ('i, 'o, 'h, 'c) ffi -> ('t -> 'i, - 'o, 'h, 'c) ffi - | Out: 't Conversion.t * doc * ('i, ('o * 't option), 'h, 'c) ffi -> - ('t oarg -> 'i, 'o, 'h, 'c) ffi - | InOut: 't ioarg Conversion.t * doc * ('i, ('o * 't option), 'h, - 'c) ffi -> ('t ioarg -> 'i, 'o, 'h, 'c) ffi - | CIn: ('t, 'h, 'c) ContextualConversion.t * doc * ('i, 'o, 'h, 'c) ffi - -> ('t -> 'i, 'o, 'h, 'c) ffi - | COut: ('t, 'h, 'c) ContextualConversion.t * doc * ('i, - ('o * 't option), 'h, 'c) ffi -> ('t oarg -> 'i, 'o, 'h, 'c) ffi - | CInOut: ('t ioarg, 'h, 'c) ContextualConversion.t * doc * ('i, - ('o * 't option), 'h, 'c) ffi -> ('t ioarg -> 'i, 'o, 'h, 'c) ffi - | Easy: doc -> (depth:int -> 'o, 'o, unit, unit) ffi - | Read: ('h, 'c) ContextualConversion.ctx_readback * doc -> - (depth:int -> 'h -> 'c -> Data.state -> 'o, 'o, 'h, 'c) ffi - | Full: ('h, 'c) ContextualConversion.ctx_readback * doc -> - (depth:int -> - 'h -> 'c -> Data.state -> (Data.state * 'o * Conversion.extra_goals), - 'o, 'h, 'c) ffi - | VariadicIn: ('h, 'c) ContextualConversion.ctx_readback * ('t, 'h, - 'c) ContextualConversion.t * doc -> - ('t list -> depth:int -> 'h -> 'c -> Data.state -> (Data.state * 'o), - 'o, 'h, 'c) ffi - | VariadicOut: ('h, 'c) ContextualConversion.ctx_readback * ('t, - 'h, 'c) ContextualConversion.t * doc -> - ('t oarg list -> - depth:int -> - 'h -> - 'c -> Data.state -> (Data.state * ('o * 't option list option)), - 'o, 'h, 'c) ffi - | VariadicInOut: ('h, 'c) ContextualConversion.ctx_readback * ('t ioarg, - 'h, 'c) ContextualConversion.t * doc -> - ('t ioarg list -> - depth:int -> - 'h -> - 'c -> Data.state -> (Data.state * ('o * 't option list option)), - 'o, 'h, 'c) ffi - type t = - | Pred: name * ('a, unit, 'h, 'c) ffi * 'a -> t - val mkData : 'a -> 'a ioarg[@@ocaml.doc - " Tools for InOut arguments.\n *\n * InOut arguments need to be equipped with an 'a ioarg Conversion.t.\n * The ioarg adaptor here maps variables to NoData and anything else to the\n * to Data of the provided 'a Conversion.t.\n *\n * If the 'a is an atomic data type, eg int, then things are good.\n * If the 'a is an algebraic data type then some more work has to be done\n * in order to have a good implementation, but the type system cannot\n * enforce it hence this documentation. Let's take the example of int option.\n * The Conversion.t to be passed is [int ioarg option ioarg Conversion.t],\n * that is, ioarg should wrap each type constructor. In this way the user\n * can pass non-ground terms. Eg\n * given term : X none some X some 3\n * readback to: NoData Data None Data (Some NoData) Data (Some (Data 3))\n *\n * Alternatively the data type 'a must be able to represent unification\n * variables, such as the raw terms, see [ioarg_any] below.\n *\n * An example of an API taking advantage of this feature is\n * pred typecheck i:term, o:ty, o:diagnostic\n * that can be used to both check a term is well typed and backtrack if not\n * typecheck T TY ok\n * or assert a term is illtyped or to test weather it is illtyped\n * typecheck T TY (error _), typecheck T TY Diagnostic\n * The ML code can see in which case we are and for example optimize the\n * first case by not even generating the error message (since error \"message\"\n * would fail to unify with ok anyway) or the second one by not assigning TY.\n "] - val ioargC : - ('t, 'h, 'c) ContextualConversion.t -> - ('t ioarg, 'h, 'c) ContextualConversion.t - val ioarg : 't Conversion.t -> 't ioarg Conversion.t - val ioarg_any : Data.term ioarg Conversion.t - module Notation : - sig - val (?:) : 'a -> (unit * 'a) - val (!:) : 'a -> (unit * 'a option) - val (+?) : 'a -> 'b -> ('a * 'b) - val (+!) : 'a -> 'b -> ('a * 'b option) - end -end -module BuiltIn : -sig - type doc_spec = - | DocAbove - | DocNext [@@ocaml.doc - " Where to print the documentation. For the running example DocAbove\n * generates\n * % [div N M D R] division of N by M gives D with reminder R\n * pred div i:int, i:int, o:int, o:int.\n * while DocNext generates\n * pred div % division of N by M gives D with reminder R\n * i:int, % N\n * i:int, % M\n * o:int, % D\n * o:int. % R\n * The latter format it is useful to give longer doc for each argument. "] - type declaration = - | MLCode of BuiltInPredicate.t * doc_spec - | MLData: 'a Conversion.t -> declaration - | MLDataC: ('a, 'h, 'c) ContextualConversion.t -> declaration - | LPDoc of string - | LPCode of string - val declare : file_name:string -> declaration list -> Setup.builtins - [@@ocaml.doc " What is passed to [Setup.init] "] - val document_fmt : Format.formatter -> Setup.builtins -> unit[@@ocaml.doc - " Prints in LP syntax the \"external\" declarations.\n * The file builtin.elpi is generated by calling this API on the\n * declaration list from elpi_builtin.ml "] - val document_file : ?header:string -> Setup.builtins -> unit -end[@@ocaml.doc - " Setup.init takes a list of declarations of data types and predicates,\n plus some doc and eventually some Elpi code. All this constitutes the\n \"prelude\", that is what is avaiable to an Elpi program "] -module Query : -sig - type name = string - type _ arguments = - | N: unit arguments - | D: 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q: 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments - type 'x t = - | Query of { - predicate: name ; - arguments: 'x arguments } - val compile : Compile.program -> Ast.Loc.t -> 'a t -> 'a Compile.query -end[@@ocaml.doc - " Commodity module to build a simple query\n and extract the output from the solution found by Elpi.\n\n Example: \"foo data Output\" where [data] has type [t] ([a] is [t Conversion.t])\n and [Output] has type [v] ([b] is a [v Conversion.t]) can be described as:\n{[\n\n let q : (v * unit) t = Query {\n predicate = \"foo\";\n arguments = D(a, data,\n Q(b, \"Output\",\n N))\n }\n\n ]}\n\n Then [compile q] can be used to obtain the compiled query such that the\n resulting solution has a fied output of type [(v * unit)]. Example:\n{[\n\n Query.compile q |> Compile.link |> Execute.once |> function\n | Execute.Success { output } -> output\n | _ -> ...\n\n ]} "] -[@@@ocaml.text - " This API lets one access the low lever representation of terms in order\n to exchange data with binders and unification variables with the host\n application. It also lets one define quotations and extend the state\n theraded by Elpi with custom data. "] -module State : -sig - type 'a component[@@ocaml.doc - " 'a MUST be purely functional, i.e. backtracking is implemented by using\n * an old binding for 'a.\n * This limitation can be lifted if there is user request. "] - val declare : - name:string -> - pp:(Format.formatter -> 'a -> unit) -> - init:(unit -> 'a) -> 'a component - type t = Data.state - val get : 'a component -> t -> 'a - val set : 'a component -> t -> 'a -> t - val update : 'a component -> t -> ('a -> 'a) -> t[@@ocaml.doc - " Allowed to raise BuiltInPredicate.No_clause "] - val update_return : 'a component -> t -> ('a -> ('a * 'b)) -> (t * 'b) -end[@@ocaml.doc - " State is a collection of purely functional piece of data carried\n by the interpreter. Such data is kept in sync with the backtracking, i.e.\n changes made in a branch are lost if that branch fails.\n It can be used to both store custom constraints to be manipulated by\n custom solvers, or any other piece of data the host application may\n need to use. "] -module FlexibleData : -sig - module Elpi : - sig - type t - val make : ?name:string -> Data.state -> (Data.state * t) - val get : name:string -> Data.state -> t option - val pp : Format.formatter -> t -> unit - val show : t -> string - val equal : t -> t -> bool - end[@@ocaml.doc " key for Elpi's flexible data "] - module type Host = - sig - type t - val compare : t -> t -> int - val pp : Format.formatter -> t -> unit - val show : t -> string - end - module Map : - functor (Host : Host) -> - sig - type t - val empty : t - val add : Elpi.t -> Host.t -> t -> t - val remove_elpi : Elpi.t -> t -> t - val remove_host : Host.t -> t -> t - val filter : (Host.t -> Elpi.t -> bool) -> t -> t - val fold : - (Host.t -> Elpi.t -> Data.term option -> 'a -> 'a) -> t -> 'a -> 'a - val elpi : Host.t -> t -> Elpi.t - val host : Elpi.t -> t -> Host.t - val uvmap : t State.component - val pp : Format.formatter -> t -> unit - val show : t -> string - end - [@@@ocaml.text - " Example from Hol-light + elpi:\n{[\n\n module UV2STV = FlexibleData.Map(struct\n type t = int\n let compare x y = x - y\n let pp fmt i = Format.fprintf fmt \"%d\" i\n let show = string_of_int\n end)\n\n let stv = ref 0\n let incr_get r = incr r; !r\n\n let record k state =\n State.update_return UV2STV.uvmap state (fun m ->\n try m, Stv (UV2STV.host k m)\n with Not_found ->\n let j = incr_get stv in\n UV2STV.add k j m, Stv j)\n\n (* The constructor name \"uvar\" is special and has to be used with the\n following Conversion.t *)\n\n let hol_pretype = AlgebraicData.declare {\n ty = TyName \"pretype\";\n doc = \"The algebraic data type of pretypes\";\n pp = (fun fmt t -> ...);\n constructors = [\n ...\n K(\"uvar\",\"\",A(uvar,N),\n BS (fun (k,_) state -> record k state),\n M (fun ~ok ~ko _ -> ko ()))\n ]\n }\n\n ]}\n\n In this way an Elpi term containig a variable [X] twice gets read back\n using [Stv i] for the same [i].\n\n "] - val uvar : (Elpi.t * Data.term list) Conversion.t -end[@@ocaml.doc - " Flexible data is for unification variables. One can use Elpi's unification\n variables to represent the host equivalent, here the API the keep a link\n between the two. "] -module RawOpaqueData : -sig - type name = string - type doc = string - type t - type 'a declaration = 'a OpaqueData.declaration = - { - name: name ; - doc: doc ; - pp: Format.formatter -> 'a -> unit ; - compare: 'a -> 'a -> int ; - hash: 'a -> int ; - hconsed: bool ; - constants: (name * 'a) list }[@@ocaml.doc - " If the data_hconsed is true, then the [cin] function below will\n automatically hashcons the data using the [eq] and [hash] functions. "] - type 'a cdata = private - { - cin: 'a -> t ; - isc: t -> bool ; - cout: t -> 'a ; - name: string } - val declare : 'a declaration -> ('a cdata * 'a Conversion.t) - val pp : Format.formatter -> t -> unit - val show : t -> string - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string - val hcons : t -> t - val ty2 : 'a cdata -> t -> t -> bool - val morph1 : 'a cdata -> ('a -> 'a) -> t -> t - val morph2 : 'a cdata -> ('a -> 'a -> 'a) -> t -> t -> t - val map : 'a cdata -> 'b cdata -> ('a -> 'b) -> t -> t - val int : int cdata - val is_int : t -> bool - val to_int : t -> int - val of_int : int -> Data.term - val float : float cdata - val is_float : t -> bool - val to_float : t -> float - val of_float : float -> Data.term - val string : string cdata - val is_string : t -> bool - val to_string : t -> string - val of_string : string -> Data.term - val loc : Ast.Loc.t cdata - val is_loc : t -> bool - val to_loc : t -> Ast.Loc.t - val of_loc : Ast.Loc.t -> Data.term -end[@@ocaml.doc " Low level module for OpaqueData "] -module RawData : -sig - type constant = int[@@ocaml.doc - " De Bruijn levels (not indexes):\n the distance of the binder from the root.\n Starts at 0 and grows for bound variables;\n global constants have negative values. "] - type builtin[@@ocaml.doc - " De Bruijn levels (not indexes):\n the distance of the binder from the root.\n Starts at 0 and grows for bound variables;\n global constants have negative values. "] - type term = Data.term - type view = private - | Const of constant - | Lam of term - | App of constant * term * term list - | Cons of term * term - | Nil - | Builtin of builtin * term list - | CData of RawOpaqueData.t - | UnifVar of FlexibleData.Elpi.t * term list - val look : depth:int -> term -> view[@@ocaml.doc - " Terms must be inspected after dereferencing their head.\n If the resulting term is UVar then its uvar_body is such that\n get_assignment uvar_body = None "] - val kool : view -> term - val mkBound : constant -> term[@@ocaml.doc " Smart constructors "] - val mkLam : term -> term - val mkCons : term -> term -> term - val mkNil : term - val mkDiscard : term - val mkCData : RawOpaqueData.t -> term - val mkUnifVar : FlexibleData.Elpi.t -> args:term list -> State.t -> term - val mkGlobal : constant -> term[@@ocaml.doc - " Lower level smart constructors "] - val mkApp : constant -> term -> term list -> term - val mkAppL : constant -> term list -> term - val mkBuiltin : builtin -> term list -> term - val mkConst : constant -> term - val cmp_builtin : builtin -> builtin -> int - type hyp = { - hdepth: int ; - hsrc: term } - type hyps = hyp list - val of_hyps : Data.hyp list -> hyps - type suspended_goal = { - context: hyps ; - goal: (int * term) } - val constraints : Data.constraints -> suspended_goal list - val no_constraints : Data.constraints - module Constants : - sig - val declare_global_symbol : string -> constant - val show : constant -> string - val eqc : constant - val orc : constant - val andc : constant - val rimplc : constant - val pic : constant - val sigmac : constant - val implc : constant - val cutc : constant - val ctypec : constant - val spillc : constant - module Map : Map.S with type key = constant - module Set : Set.S with type elt = constant - end -end[@@ocaml.doc - " This module exposes the low level representation of terms.\n *\n * The data type [term] is opaque and can only be accessed by using the\n * [look] API that exposes a term [view]. The [look] view automatically\n * substitutes assigned unification variables by their value. "] -module RawQuery : -sig - val mk_Arg : - State.t -> name:string -> args:Data.term list -> (State.t * Data.term) - val is_Arg : State.t -> Data.term -> bool - val compile : - Compile.program -> - (depth:int -> State.t -> (State.t * (Ast.Loc.t * Data.term))) -> - unit Compile.query -end[@@ocaml.doc - " This module lets one generate a query by providing a RawData.term directly "] -module Quotation : -sig - type quotation = - depth:int -> State.t -> Ast.Loc.t -> string -> (State.t * Data.term) - val set_default_quotation : quotation -> unit[@@ocaml.doc - " The default quotation [{{code}}] "] - val register_named_quotation : name:string -> quotation -> unit[@@ocaml.doc - " Named quotation [{{name:code}}] "] - val lp : quotation[@@ocaml.doc " The anti-quotation to lambda Prolog "] - val quote_syntax_runtime : - State.t -> 'a Compile.query -> (State.t * Data.term list * Data.term) - [@@ocaml.doc - " See elpi-quoted_syntax.elpi (EXPERIMENTAL, used by elpi-checker) "] - val quote_syntax_compiletime : - State.t -> 'a Compile.query -> (State.t * Data.term list * Data.term) - val term_at : depth:int -> State.t -> Ast.query -> (State.t * Data.term) - [@@ocaml.doc - " To implement the string_to_term built-in (AVOID, makes little sense\n * if depth is non zero, since bound variables have no name!) "] - [@@@ocaml.text - " Like quotations but for identifiers that begin and end with\n * \"`\" or \"'\", e.g. `this` and 'that'. Useful if the object language\n * needs something that looks like a string but with a custom compilation\n * (e.g. CD.string like but with a case insensitive comparison) "] - val declare_backtick : - name:string -> (State.t -> string -> (State.t * Data.term)) -> unit - val declare_singlequote : - name:string -> (State.t -> string -> (State.t * Data.term)) -> unit -end -module Utils : -sig - val error : ?loc:Ast.Loc.t -> string -> 'a[@@ocaml.doc - " A regular error (fatal) "] - val anomaly : ?loc:Ast.Loc.t -> string -> 'a[@@ocaml.doc - " An invariant is broken, i.e. a bug "] - val type_error : ?loc:Ast.Loc.t -> string -> 'a[@@ocaml.doc - " A type error (in principle ruled out by [elpi-checker.elpi]) "] - val warn : ?loc:Ast.Loc.t -> string -> unit[@@ocaml.doc - " A non fatal warning "] - val list_to_lp_list : Data.term list -> Data.term[@@ocaml.doc - " link between OCaml and LP lists. Note that [1,2|X] is not a valid\n * OCaml list! "] - val lp_list_to_list : depth:int -> Data.term -> Data.term list - val get_assignment : FlexibleData.Elpi.t -> Data.term option[@@ocaml.doc - " The body of an assignment, if any (LOW LEVEL).\n * Use [look] and forget about this API since the term you get\n * needs to be moved and/or reduced, and you have no API for this. "] - val clause_of_term : - ?name:string -> - ?graft:([ `After | `Before ] * string) -> - depth:int -> Ast.Loc.t -> Data.term -> Ast.program[@@ocaml.doc - " Hackish, in particular the output should be a compiled program "] - val move : from:int -> to_:int -> Data.term -> Data.term[@@ocaml.doc - " Lifting/restriction/beta (LOW LEVEL, don't use) "] - val beta : depth:int -> Data.term -> Data.term list -> Data.term - val map_acc : - (State.t -> 't -> (State.t * 'a * Conversion.extra_goals)) -> - State.t -> 't list -> (State.t * 'a list * Conversion.extra_goals) - [@@ocaml.doc " readback/embed on lists "] - module type Show = - sig type t val pp : Format.formatter -> t -> unit val show : t -> string - end - module type Show1 = - sig - type 'a t - val pp : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val show : (Format.formatter -> 'a -> unit) -> 'a t -> string - end - module Map : - sig - module type S = - sig include Map.S include Show1 with type 'a t := 'a t end - module type OrderedType = - sig include Map.OrderedType include Show with type t := t end - module Make : functor (Ord : OrderedType) -> S with type key = Ord.t - end - module Set : - sig - module type S = sig include Set.S include Show with type t := t end - module type OrderedType = - sig include Set.OrderedType include Show with type t := t end - module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t - end -end -module RawPp : -sig - val term : int -> Format.formatter -> Data.term -> unit[@@ocaml.doc - " If the term is under [depth] binders this is the function that has to be\n * called in order to print the term correct. WARNING: as of today printing\n * an open term (i.e. containing unification variables) in the *wrong* depth\n * can cause the pruning of the unification variable.\n * This behavior shall be cleaned up in the future "] - val constraints : Format.formatter -> Data.constraints -> unit - val list : - ?max:int -> - ?boxed:bool -> - (Format.formatter -> 'a -> unit) -> - ?pplastelem:(Format.formatter -> 'a -> unit) -> - string -> Format.formatter -> 'a list -> unit - module Debug : - sig - val term : int -> Format.formatter -> Data.term -> unit - val show_term : Data.term -> string - end -end -[@@@ocaml.text "/*"] - diff --git a/src/.ppcache/builtin.ml b/src/.ppcache/builtin.ml new file mode 100644 index 000000000..e69de29bb diff --git a/src/.ppcache/builtin.mli b/src/.ppcache/builtin.mli new file mode 100644 index 000000000..836fa3f8b --- /dev/null +++ b/src/.ppcache/builtin.mli @@ -0,0 +1,56 @@ +(*2e0e48bc925828ab0ecba74ffc97af5e3324c92f *src/builtin.mli --cookie elpi_trace="false"*) +#1 "src/builtin.mli" +open API.BuiltIn +val core_builtins : declaration list +val io_builtins : declaration list +val lp_builtins : declaration list +val elpi_builtins : declaration list +val elpi_nonlogical_builtins : declaration list +val elpi_stdlib : declaration list +val elpi_map : declaration list +val elpi_set : declaration list +val ocaml_map : + name:string -> + ('a, API.Conversion.ctx) API.Conversion.t -> + (module API.Utils.Map.S with type key = 'a) -> declaration list +[@@ocaml.doc + " Easy export of OCaml's Map/Set modules, use as follows:\n module StrMap = API.Utils.Map.Make(String)\n ocaml_map ~name:\"strmap\" BuiltInData.string (module StrMap) "] +val ocaml_set : + name:string -> + ('a, API.Conversion.ctx) API.Conversion.t -> + (module API.Utils.Set.S with type elt = 'a) -> declaration list +val std_declarations : declaration list +val std_builtins : API.Setup.builtins +val pair : + ('a, 'c) API.Conversion.t -> + ('b, 'c) API.Conversion.t -> (('a * 'b), 'c) API.Conversion.t +val option : ('a, 'c) API.Conversion.t -> ('a option, 'c) API.Conversion.t +val bool : (bool, 'c) API.Conversion.t +val char : (char, 'c) API.Conversion.t +val triple : + ('a, 'h) API.Conversion.t -> + ('b, 'h) API.Conversion.t -> + ('c, 'h) API.Conversion.t -> (('a * 'b * 'c), 'h) API.Conversion.t +val quadruple : + ('a, 'h) API.Conversion.t -> + ('b, 'h) API.Conversion.t -> + ('c, 'h) API.Conversion.t -> + ('d, 'h) API.Conversion.t -> + (('a * 'b * 'c * 'd), 'h) API.Conversion.t +val quintuple : + ('a, 'h) API.Conversion.t -> + ('b, 'h) API.Conversion.t -> + ('c, 'h) API.Conversion.t -> + ('d, 'h) API.Conversion.t -> + ('e, 'h) API.Conversion.t -> + (('a * 'b * 'c * 'd * 'e), 'h) API.Conversion.t +type diagnostic = private + | OK + | ERROR of string API.BuiltInPredicate.ioarg +val diagnostic : (diagnostic, 'c) API.Conversion.t +val mkOK : diagnostic +val mkERROR : string -> diagnostic +val in_stream : ((in_channel * string), 'c) API.Conversion.t +val out_stream : ((out_channel * string), 'c) API.Conversion.t +val default_checker : unit -> API.Compile.program + diff --git a/src/.ppcache/compiler.ml b/src/.ppcache/compiler.ml index 8f1361f96..aeaad9199 100644 --- a/src/.ppcache/compiler.ml +++ b/src/.ppcache/compiler.ml @@ -1,4 +1,4 @@ -(*2d1e91f72ff28de5f87971da214ef74780dddbf1 *src/compiler.ml *) +(*456a86c1e7ead6322ffd1d9e45fcecda7099e3ac *src/compiler.ml *) #1 "src/compiler.ml" open Util module F = Ast.Func @@ -291,7 +291,7 @@ module Builtins : ~compilation_is_over:(fun x -> Some x) ~execution_is_over:(fun _ -> None) let all state = (D.State.get builtins state).constants - let register state (D.BuiltInPredicate.Pred (s, _, _) as b) = + let register state (D.BuiltInPredicate.Pred (s, _, _, _) as b) = if s = "" then anomaly "Built-in predicate name must be non empty"; if not (D.State.get D.while_compiling state) then anomaly "Built-in can only be declared at compile time"; @@ -1238,7 +1238,7 @@ module WithMain = chr: (constant list * prechr_rule list) list ; initial_depth: int ; query: preterm ; - query_arguments: 'a Query.arguments [@opaque ]; + query_readback: 'a query_readback [@opaque ]; initial_goal: term ; assignments: term StrMap.t ; compiler_state: State.t }[@@deriving show] @@ -1385,10 +1385,10 @@ module WithMain = Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "query_arguments"; + "query_readback"; ((fun _ -> Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.query_arguments; + "")) x.query_readback; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " @@ -1651,12 +1651,14 @@ module ToDBL : val query_preterm_of_ast : depth:int -> macro_declaration -> - State.t -> (Loc.t * Ast.Term.t) -> (State.t * preterm) + State.t -> + (Loc.t * Ast.Term.t) -> (State.t * preterm * unit query_readback) val query_preterm_of_function : depth:int -> macro_declaration -> State.t -> - (State.t -> (State.t * (Loc.t * term))) -> (State.t * preterm) + (State.t -> (State.t * (Loc.t * term) * 'a query_readback)) -> + (State.t * preterm * 'a query_readback) val lp : quotation val is_Arg : State.t -> term -> bool val fresh_Arg : @@ -1911,12 +1913,13 @@ module ToDBL : let query_preterm_of_function ~depth macros state f = assert (is_empty_amap (get_argmap state)); (let state = set_mtm state (Some { macros }) in - let (state, (loc, term)) = f state in - let amap = get_argmap state in (state, { amap; term; loc })) + let (state, (loc, term), readback) = f state in + let amap = get_argmap state in (state, { amap; term; loc }, readback)) let query_preterm_of_ast ~depth macros state (loc, t) = assert (is_empty_amap (get_argmap state)); (let (state, term) = preterm_of_ast loc ~depth macros state t in - let amap = get_argmap state in (state, { term; amap; loc })) + let amap = get_argmap state in + (state, { term; amap; loc }, (fun _ -> fun _ -> fun _ -> ()))) open Ast.Structured let check_no_overlap_macros _ _ = () let compile_macro m { Ast.Macro.loc = loc; name = n; body } = @@ -2562,7 +2565,7 @@ module Spill : let rec spaux ((depth, vars) as ctx) = function | App (c, fcall, rest) when c == D.Global_symbols.spillc -> - (assert (rest = []); + (if rest <> [] then error ~loc "Spilling cannot be applied"; (let (spills, fcall) = spaux1 ctx fcall in let args = mkSpilled (List.rev vars) @@ -2612,7 +2615,10 @@ module Spill : | Cons (hd, tl) -> let (sp1, hd) = spaux ctx hd in let (sp2, tl) = spaux ctx tl in - (assert (((List.length hd) = 1) && ((List.length tl) = 1)); + (if not (((List.length hd) = 1) && ((List.length tl) = 1)) + then + error ~loc + "Spilling in a list, but I don't know if it is a list of props"; ((sp1 @ sp2), [Cons ((List.hd hd), (List.hd tl))])) | Builtin (c, args) -> let (spills, args) = @@ -2935,7 +2941,7 @@ let query_of_ast compiler_state assembled_program t = let type_abbrevs = assembled_program.Assembled.type_abbrevs in let modes = assembled_program.Assembled.modes in let active_macros = assembled_program.Assembled.toplevel_macros in - let (state, query) = + let (state, query, query_readback) = ToDBL.query_preterm_of_ast ~depth:initial_depth active_macros compiler_state t in let query = @@ -2955,7 +2961,7 @@ let query_of_ast compiler_state assembled_program t = chr = (assembled_program.Assembled.chr); initial_depth; query; - query_arguments = Query.N; + query_readback; initial_goal; assignments; compiler_state = (state |> (uvbodies_of_assignments assignments)) @@ -2966,9 +2972,9 @@ let query_of_term compiler_state assembled_program f = let type_abbrevs = assembled_program.Assembled.type_abbrevs in let modes = assembled_program.Assembled.modes in let active_macros = assembled_program.Assembled.toplevel_macros in - let (state, query) = + let (state, query, query_readback) = ToDBL.query_preterm_of_function ~depth:initial_depth active_macros - compiler_state (f ~depth:initial_depth) in + compiler_state (f ~depth:initial_depth [] []) in let query_env = Array.make (query.amap).nargs D.dummy in let (state, queryt) = stack_term_of_preterm ~depth:initial_depth state query in @@ -2984,19 +2990,20 @@ let query_of_term compiler_state assembled_program f = chr = (assembled_program.Assembled.chr); initial_depth; query; - query_arguments = Query.N; + query_readback; initial_goal; assignments; compiler_state = (state |> (uvbodies_of_assignments assignments)) } -let query_of_data state p loc (Query.Query { arguments } as descr) = - let query = - query_of_term state p - (fun ~depth -> - fun state -> - let (state, term) = R.embed_query ~mk_Arg ~depth state descr in - (state, (loc, term))) in - { query with query_arguments = arguments } +let query_of_data state p loc qdescr = + query_of_term state p + (fun ~depth -> + fun hyps -> + fun constraints -> + fun state -> + let ((state, term), query_readback) = + R.embed_query ~mk_Arg ~depth hyps constraints state qdescr in + (state, (loc, term), query_readback)) module Compiler : sig val run : 'a query -> 'a executable end = struct let compile_chr depth state @@ -3069,7 +3076,7 @@ module Compiler : sig val run : 'a query -> 'a executable end = with | Not_found -> () let run { WithMain.types = types; modes; clauses; chr; initial_depth; - initial_goal; assignments; compiler_state = state; query_arguments } + initial_goal; assignments; compiler_state = state; query_readback } = let flags = State.get compiler_flags state in check_all_builtin_are_typed state types; @@ -3123,7 +3130,7 @@ module Compiler : sig val run : 'a query -> 'a executable end = let builtins = Hashtbl.create 17 in let pred_list = (State.get Builtins.builtins state).code in List.iter - (fun (D.BuiltInPredicate.Pred (s, _, _) as p) -> + (fun (D.BuiltInPredicate.Pred (s, _, _, _) as p) -> let (c, _) = Symbols.get_global_symbol_str state s in Hashtbl.add builtins c p) pred_list; (let symbol_table = Symbols.compile_table compiler_symbol_table in @@ -3134,7 +3141,7 @@ module Compiler : sig val run : 'a query -> 'a executable end = initial_goal; initial_runtime_state = (State.end_compilation state); assignments; - query_arguments; + query_readback; symbol_table; builtins })) @@ -3313,7 +3320,7 @@ let term_of_ast ~depth state t = ToDBL.temporary_compilation_at_runtime (fun s -> fun x -> - let (s, x) = ToDBL.query_preterm_of_ast ~depth F.Map.empty s x in + let (s, x, _) = ToDBL.query_preterm_of_ast ~depth F.Map.empty s x in let (s, t) = stack_term_of_preterm ~depth s x in (s, (t, ((x.amap).nargs)))) state t in let env = Array.make nargs D.dummy in @@ -3359,12 +3366,17 @@ let static_check ~exec ~checker:(state, program) let query = query_of_term state program (fun ~depth -> - fun state -> - assert (depth = 0); - (state, - (loc, - (App - (checkc, (R.list_to_lp_list p), - [q; R.list_to_lp_list tlist; R.list_to_lp_list talist]))))) in + fun hyps -> + fun constraints -> + fun state -> + assert (depth = 0); + (state, + (loc, + (App + (checkc, (R.list_to_lp_list p), + [q; + R.list_to_lp_list tlist; + R.list_to_lp_list talist]))), + ((fun _ -> fun _ -> fun _ -> ())))) in let executable = optimize_query query in (exec executable) <> Failure diff --git a/src/.ppcache/compiler.mli b/src/.ppcache/compiler.mli index 9f803f783..0d66ec6c2 100644 --- a/src/.ppcache/compiler.mli +++ b/src/.ppcache/compiler.mli @@ -1,4 +1,4 @@ -(*d53ed81516fb5c87752f86676d2c2b0ac20ba07f *src/compiler.mli *) +(*8c0a98148744e29da0e681c9346f03a04ce14386 *src/compiler.mli *) #1 "src/compiler.mli" open Util open Data @@ -22,7 +22,11 @@ val query_of_ast : State.t -> program -> Ast.Goal.t -> unit query val query_of_term : State.t -> program -> - (depth:int -> State.t -> (State.t * (Loc.t * term))) -> unit query + (depth:int -> + hyps -> + constraints -> + State.t -> (State.t * (Loc.t * term) * 'a query_readback)) + -> 'a query val query_of_data : State.t -> program -> Loc.t -> 'a Query.t -> 'a query val optimize_query : 'a query -> 'a executable val term_of_ast : diff --git a/src/.ppcache/data.ml b/src/.ppcache/data.ml index 2744caa30..13d70cb62 100644 --- a/src/.ppcache/data.ml +++ b/src/.ppcache/data.ml @@ -1,4 +1,4 @@ -(*83d0917ef4644ac288b486b091a03067003847df *src/data.ml *) +(*7f2ba7fa31dccc0775a96d5831ee46cdbb09241c *src/data.ml *) #1 "src/data.ml" module Fmt = Format module F = Ast.Func @@ -1381,315 +1381,203 @@ module Conversion = and show_ty_ast : ty_ast -> Ppx_deriving_runtime_proxy.string = fun x -> Ppx_deriving_runtime_proxy.Format.asprintf "%a" pp_ty_ast x[@@ocaml.warning "-32"] - type 'a embedding = - depth:int -> State.t -> 'a -> (State.t * term * extra_goals) - type 'a readback = - depth:int -> State.t -> term -> (State.t * 'a * extra_goals) - type 'a t = - { - ty: ty_ast ; - pp_doc: Format.formatter -> unit -> unit [@opaque ]; - pp: Format.formatter -> 'a -> unit [@opaque ]; - embed: 'a embedding [@opaque ]; - readback: 'a readback [@opaque ]}[@@deriving show] - let rec pp : - 'a . - (Ppx_deriving_runtime_proxy.Format.formatter -> - 'a -> Ppx_deriving_runtime_proxy.unit) - -> - Ppx_deriving_runtime_proxy.Format.formatter -> - 'a t -> Ppx_deriving_runtime_proxy.unit - = - let __0 () = pp_ty_ast in - ((let open! Ppx_deriving_runtime_proxy in - fun poly_a -> - fun fmt -> - fun x -> - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[<2>{ "; - (((((Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "Data.Conversion.ty"; - ((__0 ()) fmt) x.ty; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "pp_doc"; - ((fun _ -> - Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.pp_doc; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " "pp"; - ((fun _ -> - Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.pp; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " "embed"; - ((fun _ -> - Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.embed; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "readback"; - ((fun _ -> - Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.readback; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@ }@]") - [@ocaml.warning "-A"]) - and show : - 'a . - (Ppx_deriving_runtime_proxy.Format.formatter -> - 'a -> Ppx_deriving_runtime_proxy.unit) - -> 'a t -> Ppx_deriving_runtime_proxy.string - = - fun poly_a -> - fun x -> Ppx_deriving_runtime_proxy.Format.asprintf "%a" (pp poly_a) x - [@@ocaml.warning "-32"] exception TypeErr of ty_ast * int * term let rec show_ty_ast ?(outer= true) = function | TyName s -> s + | TyApp ("->", x, y::[]) -> + "(" ^ ((show_ty_ast x) ^ (" -> " ^ ((show_ty_ast y) ^ ")"))) | TyApp (s, x, xs) -> let t = String.concat " " (s :: (List.map (show_ty_ast ~outer:false) (x :: xs))) in if outer then t else "(" ^ (t ^ ")") - end -module ContextualConversion = - struct - type ty_ast = Conversion.ty_ast = - | TyName of string - | TyApp of string * ty_ast * ty_ast list [@@deriving show] - let rec pp_ty_ast : - Ppx_deriving_runtime_proxy.Format.formatter -> - ty_ast -> Ppx_deriving_runtime_proxy.unit - = - let __1 () = pp_ty_ast - and __0 () = pp_ty_ast in - ((let open! Ppx_deriving_runtime_proxy in - fun fmt -> - function - | TyName a0 -> - (Ppx_deriving_runtime_proxy.Format.fprintf fmt - "(@[<2>Conversion.TyName@ "; - (Ppx_deriving_runtime_proxy.Format.fprintf fmt "%S") a0; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@])") - | TyApp (a0, a1, a2) -> - (Ppx_deriving_runtime_proxy.Format.fprintf fmt - "(@[<2>Conversion.TyApp (@,"; - (((Ppx_deriving_runtime_proxy.Format.fprintf fmt "%S") a0; - Ppx_deriving_runtime_proxy.Format.fprintf fmt ",@ "; - ((__0 ()) fmt) a1); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ",@ "; - ((fun x -> - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[<2>["; - ignore - (List.fold_left - (fun sep -> - fun x -> - if sep - then - Ppx_deriving_runtime_proxy.Format.fprintf fmt - ";@ "; - ((__1 ()) fmt) x; - true) false x); - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@,]@]")) a2); - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@,))@]")) - [@ocaml.warning "-A"]) - and show_ty_ast : ty_ast -> Ppx_deriving_runtime_proxy.string = - fun x -> Ppx_deriving_runtime_proxy.Format.asprintf "%a" pp_ty_ast x[@@ocaml.warning - "-32"] - type ('a, 'hyps, 'constraints) embedding = + class ctx (h : hyps) = object method raw = h end + type ('a, 'ctx) embedding = depth:int -> - 'hyps -> - 'constraints -> State.t -> 'a -> (State.t * term * extra_goals) - type ('a, 'hyps, 'constraints) readback = + 'ctx -> + constraints -> State.t -> 'a -> (State.t * term * extra_goals) + constraint 'ctx = #ctx + type ('a, 'ctx) readback = depth:int -> - 'hyps -> - 'constraints -> State.t -> term -> (State.t * 'a * extra_goals) - type ('a, 'hyps, 'constraints) t = + 'ctx -> + constraints -> State.t -> term -> (State.t * 'a * extra_goals) + constraint 'ctx = #ctx + type ('a, 'ctx) t = { ty: ty_ast ; pp_doc: Format.formatter -> unit -> unit [@opaque ]; pp: Format.formatter -> 'a -> unit [@opaque ]; - embed: ('a, 'hyps, 'constraints) embedding [@opaque ]; - readback: ('a, 'hyps, 'constraints) readback [@opaque ]}[@@deriving - show] + embed: ('a, 'ctx) embedding [@opaque ]; + readback: ('a, 'ctx) readback [@opaque ]} constraint 'ctx = #ctx + [@@deriving show] let rec pp : - 'a 'hyps 'constraints . + 'a 'ctx . (Ppx_deriving_runtime_proxy.Format.formatter -> 'a -> Ppx_deriving_runtime_proxy.unit) -> (Ppx_deriving_runtime_proxy.Format.formatter -> - 'hyps -> Ppx_deriving_runtime_proxy.unit) + 'ctx -> Ppx_deriving_runtime_proxy.unit) -> - (Ppx_deriving_runtime_proxy.Format.formatter -> - 'constraints -> Ppx_deriving_runtime_proxy.unit) - -> - Ppx_deriving_runtime_proxy.Format.formatter -> - ('a, 'hyps, 'constraints) t -> Ppx_deriving_runtime_proxy.unit + Ppx_deriving_runtime_proxy.Format.formatter -> + ('a, 'ctx) t -> Ppx_deriving_runtime_proxy.unit = let __0 () = pp_ty_ast in ((let open! Ppx_deriving_runtime_proxy in fun poly_a -> - fun poly_hyps -> - fun poly_constraints -> - fun fmt -> - fun x -> - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[<2>{ "; - (((((Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "Data.ContextualConversion.ty"; - ((__0 ()) fmt) x.ty; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "pp_doc"; - ((fun _ -> - Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.pp_doc; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "pp"; - ((fun _ -> - Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.pp; + fun poly_ctx -> + fun fmt -> + fun x -> + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[<2>{ "; + (((((Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " + "Data.Conversion.ty"; + ((__0 ()) fmt) x.ty; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "embed"; + "pp_doc"; ((fun _ -> Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.embed; + "")) x.pp_doc; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " - "readback"; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " "pp"; ((fun _ -> Ppx_deriving_runtime_proxy.Format.pp_print_string fmt - "")) x.readback; + "")) x.pp; Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); - Ppx_deriving_runtime_proxy.Format.fprintf fmt "@ }@]") + Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " + "embed"; + ((fun _ -> + Ppx_deriving_runtime_proxy.Format.pp_print_string fmt + "")) x.embed; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); + Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " + "readback"; + ((fun _ -> + Ppx_deriving_runtime_proxy.Format.pp_print_string fmt + "")) x.readback; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@ }@]") [@ocaml.warning "-A"]) and show : - 'a 'hyps 'constraints . + 'a 'ctx . (Ppx_deriving_runtime_proxy.Format.formatter -> 'a -> Ppx_deriving_runtime_proxy.unit) -> (Ppx_deriving_runtime_proxy.Format.formatter -> - 'hyps -> Ppx_deriving_runtime_proxy.unit) - -> - (Ppx_deriving_runtime_proxy.Format.formatter -> - 'constraints -> Ppx_deriving_runtime_proxy.unit) - -> ('a, 'hyps, 'constraints) t -> Ppx_deriving_runtime_proxy.string + 'ctx -> Ppx_deriving_runtime_proxy.unit) + -> ('a, 'ctx) t -> Ppx_deriving_runtime_proxy.string = fun poly_a -> - fun poly_hyps -> - fun poly_constraints -> - fun x -> - Ppx_deriving_runtime_proxy.Format.asprintf "%a" - (((pp poly_a) poly_hyps) poly_constraints) x[@@ocaml.warning - "-32"] - type ('hyps, 'constraints) ctx_readback = - depth:int -> - hyps -> - constraints -> - State.t -> (State.t * 'hyps * 'constraints * extra_goals) - let unit_ctx : (unit, unit) ctx_readback = - fun ~depth:_ -> fun _ -> fun _ -> fun s -> (s, (), (), []) - let raw_ctx : (hyps, constraints) ctx_readback = - fun ~depth:_ -> fun h -> fun c -> fun s -> (s, h, c, []) - let (!<) { ty; pp_doc; pp; embed; readback } = - { - Conversion.ty = ty; - pp; - pp_doc; - embed = (fun ~depth -> fun s -> fun t -> embed ~depth () () s t); - readback = - (fun ~depth -> fun s -> fun t -> readback ~depth () () s t) - } - let (!>) { Conversion.ty = ty; pp_doc; pp; embed; readback } = + fun poly_ctx -> + fun x -> + Ppx_deriving_runtime_proxy.Format.asprintf "%a" ((pp poly_a) poly_ctx) + x[@@ocaml.warning "-32"] + type 'a ctx_entry = { + entry: 'a ; + depth: int }[@@deriving show] + let rec pp_ctx_entry : + 'a . + (Ppx_deriving_runtime_proxy.Format.formatter -> + 'a -> Ppx_deriving_runtime_proxy.unit) + -> + Ppx_deriving_runtime_proxy.Format.formatter -> + 'a ctx_entry -> Ppx_deriving_runtime_proxy.unit + = + ((let open! Ppx_deriving_runtime_proxy in + fun poly_a -> + fun fmt -> + fun x -> + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[<2>{ "; + ((Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " + "Data.Conversion.entry"; + (poly_a fmt) x.entry; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); + Ppx_deriving_runtime_proxy.Format.fprintf fmt ";@ "; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@[%s =@ " "depth"; + (Ppx_deriving_runtime_proxy.Format.fprintf fmt "%d") x.depth; + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@]"); + Ppx_deriving_runtime_proxy.Format.fprintf fmt "@ }@]") + [@ocaml.warning "-A"]) + and show_ctx_entry : + 'a . + (Ppx_deriving_runtime_proxy.Format.formatter -> + 'a -> Ppx_deriving_runtime_proxy.unit) + -> 'a ctx_entry -> Ppx_deriving_runtime_proxy.string + = + fun poly_a -> + fun x -> + Ppx_deriving_runtime_proxy.Format.asprintf "%a" (pp_ctx_entry poly_a) x + [@@ocaml.warning "-32"] + type 'a ctx_field = 'a ctx_entry Constants.Map.t + type hyp = clause_src + type ('a, 'k, 'h) context = { - ty; - pp; - pp_doc; - embed = - (fun ~depth -> fun _ -> fun _ -> fun s -> fun t -> embed ~depth s t); - readback = - (fun ~depth -> - fun _ -> fun _ -> fun s -> fun t -> readback ~depth s t) - } - let (!>>) (f : 'a Conversion.t -> 'b Conversion.t) cc = - let mk h c { ty; pp_doc; pp; embed; readback } = - { - Conversion.ty = ty; - pp; - pp_doc; - embed = (fun ~depth -> fun s -> fun t -> embed ~depth h c s t); - readback = - (fun ~depth -> fun s -> fun t -> readback ~depth h c s t) - } in - let mk_pp { ty; pp_doc; pp } = - { - Conversion.ty = ty; - pp; - pp_doc; - embed = (fun ~depth -> fun s -> fun t -> assert false); - readback = (fun ~depth -> fun s -> fun t -> assert false) - } in - let { Conversion.ty = ty; pp; pp_doc } = f (mk_pp cc) in + is_entry_for_nominal: hyp -> constant option ; + to_key: depth:int -> 'a -> 'k ; + push: depth:int -> State.t -> 'k -> 'a ctx_entry -> State.t ; + pop: depth:int -> State.t -> 'k -> State.t ; + conv: ((constant * 'a), #ctx as 'h) t ; + init: State.t -> State.t ; + get: State.t -> 'a ctx_field } + type 'ctx ctx_readback = + depth:int -> + hyps -> constraints -> State.t -> (State.t * 'ctx * extra_goals) + constraint 'ctx = #ctx + type ('a, 'ctx) context_builder = + depth:int -> + constraints -> + 'a list -> + State.t -> + (State.t * term ctx_entry Constants.Map.t * 'ctx * extra_goals) + constraint 'ctx = #ctx + type dummy = unit + let dummy = { - ty; - pp; - pp_doc; + ty = (TyName "dummy"); + pp = (fun _ -> fun _ -> assert false); + pp_doc = (fun _ -> fun _ -> assert false); embed = - (fun ~depth -> - fun h -> - fun c -> fun s -> fun t -> (f (mk h c cc)).embed ~depth s t); + (fun ~depth -> fun _ -> fun _ -> fun _ -> fun _ -> assert false); readback = - (fun ~depth -> - fun h -> - fun c -> fun s -> fun t -> (f (mk h c cc)).readback ~depth s t) + (fun ~depth -> fun _ -> fun _ -> fun _ -> fun _ -> assert false) } - let (!>>>) (f : 'a Conversion.t -> 'b Conversion.t -> 'c Conversion.t) cc - dd = - let mk h c { ty; pp_doc; pp; embed; readback } = - { - Conversion.ty = ty; - pp; - pp_doc; - embed = (fun ~depth -> fun s -> fun t -> embed ~depth h c s t); - readback = - (fun ~depth -> fun s -> fun t -> readback ~depth h c s t) - } in - let mk_pp { ty; pp_doc; pp } = - { - Conversion.ty = ty; - pp; - pp_doc; - embed = (fun ~depth -> fun s -> fun t -> assert false); - readback = (fun ~depth -> fun s -> fun t -> assert false) - } in - let { Conversion.ty = ty; pp; pp_doc } = f (mk_pp cc) (mk_pp dd) in + let in_raw = { - ty; - pp; - pp_doc; - embed = - (fun ~depth -> - fun h -> - fun c -> - fun s -> - fun t -> (f (mk h c cc) (mk h c dd)).embed ~depth s t); - readback = - (fun ~depth -> - fun h -> - fun c -> - fun s -> - fun t -> (f (mk h c cc) (mk h c dd)).readback ~depth s t) + is_entry_for_nominal = (fun _ -> None); + to_key = (fun ~depth -> fun _ -> ()); + push = (fun ~depth -> fun st -> fun _ -> fun _ -> st); + pop = (fun ~depth -> fun st -> fun _ -> st); + conv = dummy; + init = (fun st -> st); + get = (fun st -> Constants.Map.empty) } + let build_raw_ctx h s = (new ctx) h + let in_raw_ctx : ctx ctx_readback = + fun ~depth:_ -> fun h -> fun c -> fun s -> (s, (build_raw_ctx h s), []) + let context_builder { conv; to_key; push; init } obj_builder hyps = + (let do1 ~depth csts a m st = + let k = to_key ~depth a in + let st = push ~depth st k { depth; entry = a } in + let (st, a, gls) = conv.embed ~depth hyps csts st (depth, a) in + (st, (Constants.Map.add depth { depth; entry = a } m), gls) in + fun ~depth -> + fun csts -> + fun items -> + fun st -> + let st = init st in + let (st, m, glsl_rev, _) = + List.fold_left + (fun (st, m, gls, depth) -> + fun a -> + let (st, m, g) = do1 ~depth csts a m st in + (st, m, (g :: gls), (depth + 1))) + (st, Constants.Map.empty, [], depth) items in + (st, m, (obj_builder st), (List.concat (List.rev glsl_rev))) : + ('a, 'h) context_builder) end let while_compiling = State.declare ~name:"elpi:compiling" ~pp:(fun fmt -> fun _ -> ()) @@ -1707,44 +1595,40 @@ module BuiltInPredicate = type 'a ioarg = | Data of 'a | NoData - type ('function_type, 'inernal_outtype_in, 'internal_hyps, - 'internal_constraints) ffi = - | In: 't Conversion.t * doc * ('i, 'o, 'h, 'c) ffi -> ('t -> 'i, - 'o, 'h, 'c) ffi - | Out: 't Conversion.t * doc * ('i, ('o * 't option), 'h, 'c) ffi -> - ('t oarg -> 'i, 'o, 'h, 'c) ffi - | InOut: 't ioarg Conversion.t * doc * ('i, ('o * 't option), 'h, - 'c) ffi -> ('t ioarg -> 'i, 'o, 'h, 'c) ffi - | CIn: ('t, 'h, 'c) ContextualConversion.t * doc * ('i, 'o, 'h, - 'c) ffi -> ('t -> 'i, 'o, 'h, 'c) ffi - | COut: ('t, 'h, 'c) ContextualConversion.t * doc * ('i, - ('o * 't option), 'h, 'c) ffi -> ('t oarg -> 'i, 'o, 'h, 'c) ffi - | CInOut: ('t ioarg, 'h, 'c) ContextualConversion.t * doc * ('i, - ('o * 't option), 'h, 'c) ffi -> ('t ioarg -> 'i, 'o, 'h, 'c) ffi - | Easy: doc -> (depth:int -> 'o, 'o, unit, unit) ffi - | Read: ('h, 'c) ContextualConversion.ctx_readback * doc -> - (depth:int -> 'h -> 'c -> State.t -> 'o, 'o, 'h, 'c) ffi - | Full: ('h, 'c) ContextualConversion.ctx_readback * doc -> - (depth:int -> 'h -> 'c -> State.t -> (State.t * 'o * extra_goals), - 'o, 'h, 'c) ffi - | VariadicIn: ('h, 'c) ContextualConversion.ctx_readback * ('t, - 'h, 'c) ContextualConversion.t * doc -> - ('t list -> depth:int -> 'h -> 'c -> State.t -> (State.t * 'o), - 'o, 'h, 'c) ffi - | VariadicOut: ('h, 'c) ContextualConversion.ctx_readback * ('t, - 'h, 'c) ContextualConversion.t * doc -> + type ('function_type, 'inernal_outtype_in, 'internal_hyps) ffi = + | In: ('t, 'h) Conversion.t * doc * ('i, 'o, 'h) ffi -> ('t -> 'i, + 'o, 'h) ffi + | Out: ('t, 'h) Conversion.t * doc * ('i, ('o * 't option), 'h) ffi -> + ('t oarg -> 'i, 'o, 'h) ffi + | InOut: ('t ioarg, 'h) Conversion.t * doc * ('i, ('o * 't option), + 'h) ffi -> ('t ioarg -> 'i, 'o, 'h) ffi + | Easy: doc -> (depth:int -> 'o, 'o, 'h) ffi + | Read: doc -> (depth:int -> 'h -> constraints -> State.t -> 'o, + 'o, 'h) ffi + | Full: doc -> + (depth:int -> + 'h -> constraints -> State.t -> (State.t * 'o * extra_goals), + 'o, 'h) ffi + | VariadicIn: ('t, 'h) Conversion.t * doc -> + ('t list -> depth:int -> 'h -> constraints -> State.t -> (State.t * 'o), + 'o, 'h) ffi + | VariadicOut: ('t, 'h) Conversion.t * doc -> ('t oarg list -> depth:int -> - 'h -> 'c -> State.t -> (State.t * ('o * 't option list option)), - 'o, 'h, 'c) ffi - | VariadicInOut: ('h, 'c) ContextualConversion.ctx_readback * - ('t ioarg, 'h, 'c) ContextualConversion.t * doc -> + 'h -> + constraints -> + State.t -> (State.t * ('o * 't option list option)), + 'o, 'h) ffi + | VariadicInOut: ('t ioarg, 'h) Conversion.t * doc -> ('t ioarg list -> depth:int -> - 'h -> 'c -> State.t -> (State.t * ('o * 't option list option)), - 'o, 'h, 'c) ffi + 'h -> + constraints -> + State.t -> (State.t * ('o * 't option list option)), + 'o, 'h) ffi type t = - | Pred: name * ('a, unit, 'h, 'c) ffi * 'a -> t + | Pred: name * ('a, unit, 'h) ffi * 'h Conversion.ctx_readback * 'a -> + t type doc_spec = | DocAbove | DocNext @@ -1775,67 +1659,64 @@ module BuiltInPredicate = | B of 'build_t | BS of 'build_stateful_t type ('stateful_builder, 'builder, 'stateful_matcher, 'matcher, - 'self, 'hyps, 'constraints) constructor_arguments = + 'self, 'ctx) constructor_arguments = | N: (State.t -> (State.t * 'self), 'self, - State.t -> (State.t * term * extra_goals), term, 'self, 'hyps, - 'constraints) constructor_arguments - | A: 'a Conversion.t * ('bs, 'b, 'ms, 'm, 'self, 'hyps, - 'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, - 'a -> 'ms, 'a -> 'm, 'self, 'hyps, 'constraints) + State.t -> (State.t * term * extra_goals), term, 'self, 'ctx) constructor_arguments - | CA: ('a, 'hyps, 'constraints) ContextualConversion.t * ('bs, - 'b, 'ms, 'm, 'self, 'hyps, 'constraints) constructor_arguments -> - ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps, - 'constraints) constructor_arguments - | S: ('bs, 'b, 'ms, 'm, 'self, 'hyps, 'constraints) - constructor_arguments -> ('self -> 'bs, 'self -> 'b, 'self -> 'ms, - 'self -> 'm, 'self, 'hyps, 'constraints) constructor_arguments - | C: - (('self, 'hyps, 'constraints) ContextualConversion.t -> - ('a, 'hyps, 'constraints) ContextualConversion.t) - * ('bs, 'b, 'ms, 'm, 'self, 'hyps, 'constraints) + | A: ('a, 'ctx) Conversion.t * ('bs, 'b, 'ms, 'm, 'self, 'ctx) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, - 'self, 'hyps, 'constraints) constructor_arguments - type ('t, 'h, 'c) constructor = + 'self, 'ctx) constructor_arguments + | S: ('bs, 'b, 'ms, 'm, 'self, 'ctx) constructor_arguments -> + ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, + 'ctx) constructor_arguments + | C: + (('self, Conversion.ctx) Conversion.t -> + ('a, Conversion.ctx) Conversion.t) + * ('bs, 'b, 'ms, 'm, 'self, 'ctx) constructor_arguments -> + ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'ctx) + constructor_arguments + type ('t, 'h) constructor = | K: name * doc * ('build_stateful_t, 'build_t, 'match_stateful_t, - 'match_t, 't, 'h, 'c) constructor_arguments * ('build_stateful_t, + 'match_t, 't, 'h) constructor_arguments * ('build_stateful_t, 'build_t) build_t * ('match_stateful_t, 'match_t, 't) match_t -> - ('t, 'h, 'c) constructor - type ('t, 'h, 'c) declaration = + ('t, 'h) constructor + type ('t, 'h) declaration = { ty: Conversion.ty_ast ; doc: doc ; pp: Format.formatter -> 't -> unit ; - constructors: ('t, 'h, 'c) constructor list } - type ('b, 'm, 't, 'h, 'c) compiled_constructor_arguments = + constructors: ('t, 'h) constructor list } constraint 'h = + #Conversion.ctx + type ('b, 'm, 't, 'h) compiled_constructor_arguments = | XN: (State.t -> (State.t * 't), - State.t -> (State.t * term * extra_goals), 't, 'h, 'c) + State.t -> (State.t * term * extra_goals), 't, 'h) compiled_constructor_arguments - | XA: ('a, 'h, 'c) ContextualConversion.t * ('b, 'm, 't, 'h, - 'c) compiled_constructor_arguments -> ('a -> 'b, 'a -> 'm, - 't, 'h, 'c) compiled_constructor_arguments + | XA: ('a, 'h) Conversion.t * ('b, 'm, 't, 'h) + compiled_constructor_arguments -> ('a -> 'b, 'a -> 'm, 't, + 'h) compiled_constructor_arguments type ('match_t, 't) compiled_match_t = ok:'match_t -> ko:(State.t -> (State.t * term * extra_goals)) -> 't -> State.t -> (State.t * term * extra_goals) - type ('t, 'h, 'c) compiled_constructor = - | XK: ('build_t, 'matched_t, 't, 'h, 'c) - compiled_constructor_arguments * 'build_t * ('matched_t, 't) - compiled_match_t -> ('t, 'h, 'c) compiled_constructor - type ('t, 'h, 'c) compiled_adt = - ('t, 'h, 'c) compiled_constructor Constants.Map.t + type ('t, 'h) compiled_constructor = + | XK: ('build_t, 'matched_t, 't, 'h) compiled_constructor_arguments + * 'build_t * ('matched_t, 't) compiled_match_t -> ('t, 'h) + compiled_constructor + type ('t, 'h) compiled_adt = + ('t, 'h) compiled_constructor Constants.Map.t let buildk ~mkConst kname = function | [] -> mkConst kname | x::xs -> mkApp kname x xs - let rec readback_args : type a m t h c. + let rec readback_args : type a m t. look:(depth:int -> term -> term) -> Conversion.ty_ast -> depth:int -> - h -> - c -> + #Conversion.ctx -> + constraints -> State.t -> extra_goals list -> term -> - (a, m, t, h, c) compiled_constructor_arguments -> + (a, m, t, Conversion.ctx) + compiled_constructor_arguments -> a -> term list -> (State.t * t * extra_goals) = fun ~look -> @@ -1865,16 +1746,17 @@ module BuiltInPredicate = readback_args ~look ty ~depth hyps constraints state (gls :: extra) origin rest (convert x) xs - and readback : type t h c. + and readback : type t. mkinterval:(int -> int -> int -> term list) -> look:(depth:int -> term -> term) -> alloc:(?name:string -> State.t -> (State.t * 'uk)) -> mkUnifVar:('uk -> args:term list -> State.t -> term) -> Conversion.ty_ast -> - (t, h, c) compiled_adt -> + (t, Conversion.ctx) compiled_adt -> depth:int -> - h -> - c -> State.t -> term -> (State.t * t * extra_goals) + #Conversion.ctx -> + constraints -> + State.t -> term -> (State.t * t * extra_goals) = fun ~mkinterval -> fun ~look -> @@ -1922,15 +1804,16 @@ module BuiltInPredicate = with | Not_found -> raise (Conversion.TypeErr (ty, depth, t)) - and adt_embed_args : type m a t h c. + and adt_embed_args : type m a t. mkConst:(int -> term) -> Conversion.ty_ast -> - (t, h, c) compiled_adt -> + (t, Conversion.ctx) compiled_adt -> constant -> depth:int -> - h -> - c -> - (a, m, t, h, c) compiled_constructor_arguments -> + #Conversion.ctx -> + constraints -> + (a, m, t, Conversion.ctx) + compiled_constructor_arguments -> (State.t -> (State.t * term * extra_goals)) list -> m = @@ -1962,13 +1845,15 @@ module BuiltInPredicate = ((fun state -> d.embed ~depth hyps constraints state x) :: acc)) - and embed : type a h c. + and embed : type a. mkConst:(int -> term) -> Conversion.ty_ast -> (Format.formatter -> a -> unit) -> - (a, h, c) compiled_adt -> + (a, Conversion.ctx) compiled_adt -> depth:int -> - h -> c -> State.t -> a -> (State.t * term * extra_goals) + #Conversion.ctx -> + constraints -> + State.t -> a -> (State.t * term * extra_goals) = fun ~mkConst -> fun ty -> @@ -1993,38 +1878,32 @@ module BuiltInPredicate = ~depth hyps constraints args [] in matcher ~ok ~ko:(aux rest) t state in aux bindings state - let rec compile_arguments : type b bs m ms t h c. - (bs, b, ms, m, t, h, c) constructor_arguments -> - (t, h, c) ContextualConversion.t -> - (bs, ms, t, h, c) compiled_constructor_arguments + let rec compile_arguments : type b bs m ms t. + (bs, b, ms, m, t, Conversion.ctx) constructor_arguments -> + (t, #Conversion.ctx) Conversion.t -> + (bs, ms, t, Conversion.ctx) compiled_constructor_arguments = fun arg -> fun self -> match arg with | N -> XN - | A (d, rest) -> - XA - ((ContextualConversion.(!>) d), - (compile_arguments rest self)) - | CA (d, rest) -> XA (d, (compile_arguments rest self)) + | A (d, rest) -> XA (d, (compile_arguments rest self)) | S rest -> XA (self, (compile_arguments rest self)) | C (fs, rest) -> XA ((fs self), (compile_arguments rest self)) - let rec compile_builder_aux : type bs b m ms t h c. - (bs, b, ms, m, t, h, c) constructor_arguments -> b -> bs = + let rec compile_builder_aux : type bs b m ms t h. + (bs, b, ms, m, t, h) constructor_arguments -> b -> bs = fun args -> fun f -> match args with | N -> (fun state -> (state, f)) | A (_, rest) -> (fun a -> compile_builder_aux rest (f a)) - | CA (_, rest) -> (fun a -> compile_builder_aux rest (f a)) | S rest -> (fun a -> compile_builder_aux rest (f a)) | C (_, rest) -> (fun a -> compile_builder_aux rest (f a)) - let compile_builder : type bs b m ms t h c. - (bs, b, ms, m, t, h, c) constructor_arguments -> - (bs, b) build_t -> bs + let compile_builder : type bs b m ms t h. + (bs, b, ms, m, t, h) constructor_arguments -> (bs, b) build_t -> bs = fun a -> function | B f -> compile_builder_aux a f | BS f -> f - let rec compile_matcher_ok : type bs b m ms t h c. - (bs, b, ms, m, t, h, c) constructor_arguments -> + let rec compile_matcher_ok : type bs b m ms t h. + (bs, b, ms, m, t, h) constructor_arguments -> ms -> extra_goals ref -> State.t ref -> m = fun args -> @@ -2037,8 +1916,6 @@ module BuiltInPredicate = (state := state'; gls := gls'; t) | A (_, rest) -> (fun a -> compile_matcher_ok rest (f a) gls state) - | CA (_, rest) -> - (fun a -> compile_matcher_ok rest (f a) gls state) | S rest -> (fun a -> compile_matcher_ok rest (f a) gls state) | C (_, rest) -> @@ -2046,8 +1923,8 @@ module BuiltInPredicate = let compile_matcher_ko f gls state () = let (state', t, gls') = f (!state) in state := state'; gls := gls'; t - let compile_matcher : type bs b m ms t h c. - (bs, b, ms, m, t, h, c) constructor_arguments -> + let compile_matcher : type bs b m ms t h. + (bs, b, ms, m, t, h) constructor_arguments -> (ms, m, t) match_t -> (ms, t) compiled_match_t = fun a -> @@ -2064,9 +1941,9 @@ module BuiltInPredicate = ~ko:(compile_matcher_ko ko gls state) t), (!gls))) | MS f -> f - let rec tyargs_of_args : type a b c d e. + let rec tyargs_of_args : type a b c d. string -> - (a, b, c, d, e) compiled_constructor_arguments -> + (a, b, c, d) compiled_constructor_arguments -> (bool * string * string) list = fun self -> @@ -2093,28 +1970,38 @@ module BuiltInPredicate = acc), (StrMap.add name (tyargs_of_args self_name args) sacc))) (Constants.Map.empty, StrMap.empty) l + let document_compiled_constructor fmt name doc argsdoc = + Fmt.fprintf fmt "@[type %s@[%a.%s@]@]@\n" name + pp_ty_args argsdoc (if doc = "" then "" else " % " ^ doc) let document_constructor fmt name doc argsdoc = + let pp_ty sep fmt s = Fmt.fprintf fmt " %s%s" s sep in + let pp_ty_args = pplist (pp_ty "") " ->" ~pplastelem:(pp_ty "") in Fmt.fprintf fmt "@[type %s@[%a.%s@]@]@\n" name pp_ty_args argsdoc (if doc = "" then "" else " % " ^ doc) - let document_kind fmt = - function - | Conversion.TyApp (s, _, l) -> - let n = (List.length l) + 2 in - let l = Array.init n (fun _ -> "type") in - Fmt.fprintf fmt "@[kind %s %s.@]@\n" s - (String.concat " -> " (Array.to_list l)) - | Conversion.TyName s -> - Fmt.fprintf fmt "@[kind %s type.@]@\n" s - let document_adt doc ty ks cks fmt () = + let document_kind fmt ty doc = if doc <> "" then (pp_comment fmt ("% " ^ doc); Fmt.fprintf fmt "@\n"); - document_kind fmt ty; + (match ty with + | Conversion.TyApp (s, _, l) -> + let n = (List.length l) + 2 in + let l = Array.init n (fun _ -> "type") in + Fmt.fprintf fmt "@[kind %s %s.@]@\n" s + (String.concat " -> " (Array.to_list l)) + | Conversion.TyName s -> + Fmt.fprintf fmt "@[kind %s type.@]@\n" s) + let document_compiled_adt doc ty ks cks fmt () = + document_kind fmt ty doc; List.iter (fun (K (name, doc, _, _, _)) -> if name <> "uvar" then let argsdoc = StrMap.find name cks in - document_constructor fmt name doc argsdoc) ks + document_compiled_constructor fmt name doc argsdoc) ks + let document_adt doc ty ks fmt () = + document_kind fmt ty doc; + List.iter + (fun (name, doc, spec) -> document_constructor fmt name doc spec) + ks let adt ~mkinterval ~look ~mkConst ~alloc ~mkUnifVar { ty; constructors; doc; pp } = let readback_ref = @@ -2126,13 +2013,13 @@ module BuiltInPredicate = let sconstructors_ref = ref StrMap.empty in let self = { - ContextualConversion.ty = ty; + Conversion.ty = ty; pp; pp_doc = (fun fmt -> fun () -> - document_adt doc ty constructors (!sconstructors_ref) - fmt ()); + document_compiled_adt doc ty constructors + (!sconstructors_ref) fmt ()); readback = (fun ~depth -> fun hyps -> @@ -2159,8 +2046,7 @@ module BuiltInPredicate = end type declaration = | MLCode of t * doc_spec - | MLData: 'a Conversion.t -> declaration - | MLDataC: ('a, 'h, 'c) ContextualConversion.t -> declaration + | MLData: ('a, 'h) Conversion.t -> declaration | LPDoc of string | LPCode of string let pp_tab_arg i sep fmt (dir, ty, doc) = @@ -2209,8 +2095,8 @@ module BuiltInPredicate = Fmt.fprintf fmt "@[%% %a@.external type %s@[%a.@]@]@.@." pp_comment doc name pp_ty_args args let document_pred fmt docspec name ffi = - let rec doc : type i o h c. - (bool * string * string) list -> (i, o, h, c) ffi -> unit = + let rec doc : type i o h. + (bool * string * string) list -> (i, o, h) ffi -> unit = fun args -> function | In ({ Conversion.ty = ty }, s, ffi) -> @@ -2219,20 +2105,14 @@ module BuiltInPredicate = doc ((false, (Conversion.show_ty_ast ty), s) :: args) ffi | InOut ({ Conversion.ty = ty }, s, ffi) -> doc ((false, (Conversion.show_ty_ast ty), s) :: args) ffi - | CIn ({ ContextualConversion.ty = ty }, s, ffi) -> - doc ((true, (Conversion.show_ty_ast ty), s) :: args) ffi - | COut ({ ContextualConversion.ty = ty }, s, ffi) -> - doc ((false, (Conversion.show_ty_ast ty), s) :: args) ffi - | CInOut ({ ContextualConversion.ty = ty }, s, ffi) -> - doc ((false, (Conversion.show_ty_ast ty), s) :: args) ffi - | Read (_, s) -> pp_pred fmt docspec name s args + | Read s -> pp_pred fmt docspec name s args | Easy s -> pp_pred fmt docspec name s args - | Full (_, s) -> pp_pred fmt docspec name s args - | VariadicIn (_, { ContextualConversion.ty = ty }, s) -> + | Full s -> pp_pred fmt docspec name s args + | VariadicIn ({ Conversion.ty = ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args - | VariadicOut (_, { ContextualConversion.ty = ty }, s) -> + | VariadicOut ({ Conversion.ty = ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args - | VariadicInOut (_, { ContextualConversion.ty = ty }, s) -> + | VariadicInOut ({ Conversion.ty = ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args in doc [] ffi let document fmt l = @@ -2242,10 +2122,9 @@ module BuiltInPredicate = Fmt.fprintf fmt "@\n@\n"; List.iter (function - | MLCode (Pred (name, ffi, _), docspec) -> + | MLCode (Pred (name, ffi, _, _), docspec) -> document_pred fmt docspec name ffi | MLData { pp_doc } -> Fmt.fprintf fmt "%a@\n" pp_doc () - | MLDataC { pp_doc } -> Fmt.fprintf fmt "%a@\n" pp_doc () | LPCode s -> (Fmt.fprintf fmt "%s" s; Fmt.fprintf fmt "@\n@\n") | LPDoc s -> (pp_comment fmt ("% " ^ s); Fmt.fprintf fmt "@\n@\n")) l; @@ -2257,14 +2136,21 @@ module BuiltInPredicate = module Query = struct type name = string - type _ arguments = - | N: unit arguments - | D: 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q: 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments - type 'x t = - | Query of { + type ('x, 'c) arguments = + | N: (unit, 'c) arguments + | D: ('a, #Conversion.ctx as 'c) Conversion.t * 'a * ('x, 'c) arguments + -> ('x, 'c) arguments + | Q: ('a, #Conversion.ctx as 'c) Conversion.t * name * ('x, 'c) + arguments -> (('a * 'x), 'c) arguments + type 'c obj_builder = State.t -> 'c constraint 'c = #Conversion.ctx + type _ t = + | Query: ('a, 'x, 'c) query_contents * ('a, 'k, Conversion.ctx) + Conversion.context * 'c obj_builder -> 'x t + and ('a, 'x, 'c) query_contents = + { + context: 'a list ; predicate: constant ; - arguments: 'x arguments } + arguments: ('x, 'c) arguments } end type symbol_table = { @@ -2304,6 +2190,7 @@ let rec pp_symbol_table : and show_symbol_table : symbol_table -> Ppx_deriving_runtime_proxy.string = fun x -> Ppx_deriving_runtime_proxy.Format.asprintf "%a" pp_symbol_table x [@@ocaml.warning "-32"] +type 'a query_readback = term StrMap.t -> constraints -> State.t -> 'a type 'a executable = { compiled_program: prolog_prog ; @@ -2314,7 +2201,7 @@ type 'a executable = symbol_table: symbol_table ; builtins: BuiltInPredicate.builtin_table ; assignments: term Util.StrMap.t ; - query_arguments: 'a Query.arguments } + query_readback: 'a query_readback } type pp_ctx = { uv_names: (string Util.PtrMap.t * int) ref ; diff --git a/src/.ppcache/runtime_trace_off.ml b/src/.ppcache/runtime_trace_off.ml index 2bfe57cc8..ff24e298e 100644 --- a/src/.ppcache/runtime_trace_off.ml +++ b/src/.ppcache/runtime_trace_off.ml @@ -1,4 +1,4 @@ -(*25823e968f78a65500da52de3f79f1aeb00d2b5a *src/runtime_trace_off.ml --cookie elpi_trace="false"*) +(*3a434c451cdabf1a722d3fd2ed37b08e1240c2f9 *src/runtime_trace_off.ml --cookie elpi_trace="false"*) #1 "src/runtime_trace_off.ml" module Fmt = Format module F = Ast.Func @@ -1609,25 +1609,6 @@ module FFI = match deref_head ~depth t with | Discard -> Data.BuiltInPredicate.Discard | _ -> Data.BuiltInPredicate.Keep - let in_of_term ~depth readback n bname state t = - wrap_type_err bname n (readback ~depth state) t - let inout_of_term ~depth readback n bname state t = - wrap_type_err bname n (readback ~depth state) t - let mk_out_assign ~depth embed bname state input v output = - match (output, input) with - | (None, Data.BuiltInPredicate.Discard) -> (state, []) - | (Some _, Data.BuiltInPredicate.Discard) -> (state, []) - | (Some t, Data.BuiltInPredicate.Keep) -> - let (state, t, extra) = embed ~depth state t in - (state, (extra @ [App (Global_symbols.eqc, v, [t])])) - | (None, Data.BuiltInPredicate.Keep) -> (state, []) - let mk_inout_assign ~depth embed bname state input v output = - match output with - | None -> (state, []) - | Some t -> - let (state, t, extra) = - embed ~depth state (Data.BuiltInPredicate.Data t) in - (state, (extra @ [App (Global_symbols.eqc, v, [t])])) let in_of_termC ~depth readback n bname hyps constraints state t = wrap_type_err bname n (readback ~depth hyps constraints state) t let inout_of_termC = in_of_termC @@ -1656,12 +1637,12 @@ module FFI = | x::xs -> let (s, x, gls) = f s x in aux (x :: acc) (gls :: extra) s xs in aux [] [] s l - let call (Data.BuiltInPredicate.Pred (bname, ffi, compute)) ~depth hyps - constraints state data = - let rec aux : type i o h c. - (i, o, h, c) Data.BuiltInPredicate.ffi -> + let call (Data.BuiltInPredicate.Pred (bname, ffi, in_ctx, compute)) + ~depth hyps constraints state data = + let rec aux : type i o h. + (i, o, h) Data.BuiltInPredicate.ffi -> h -> - c -> + constraints -> compute:i -> reduce:(State.t -> o -> (State.t * extra_goals)) -> term list -> @@ -1703,10 +1684,8 @@ module FFI = ((let open List in concat (rev extra)) @ (gls @ (List.rev l)))) | (Data.BuiltInPredicate.VariadicIn - (_, - { ContextualConversion.readback = readback }, - _), - data) -> + ({ Conversion.readback = readback }, _), data) + -> let (state, i, gls) = map_acc (in_of_termC ~depth readback n bname ctx @@ -1719,10 +1698,7 @@ module FFI = (let open List in gls @ ((concat (rev extra)) @ (rev l)))) | (Data.BuiltInPredicate.VariadicOut - (_, - { ContextualConversion.embed = embed; readback - }, - _), + ({ Conversion.embed = embed; readback }, _), data) -> let i = List.map @@ -1747,10 +1723,7 @@ module FFI = (let open List in (concat (rev extra)) @ (rev l)))) | (Data.BuiltInPredicate.VariadicInOut - (_, - { ContextualConversion.embed = embed; readback - }, - _), + ({ Conversion.embed = embed; readback }, _), data) -> let (state, i, gls) = map_acc @@ -1776,19 +1749,16 @@ module FFI = (let open List in gls @ ((concat (rev extra)) @ (rev l))))) - | (Data.BuiltInPredicate.CIn - ({ ContextualConversion.readback = readback }, - _, ffi), + | (Data.BuiltInPredicate.In + ({ Conversion.readback = readback }, _, ffi), t::rest) -> let (state, i, gls) = in_of_termC ~depth readback n bname ctx constraints state t in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | (Data.BuiltInPredicate.COut - ({ ContextualConversion.embed = embed; readback - }, - _, ffi), + | (Data.BuiltInPredicate.Out + ({ Conversion.embed = embed; readback }, _, ffi), t::rest) -> let i = out_of_term ~depth readback n bname state t in @@ -1800,10 +1770,8 @@ module FFI = (state, (ass @ l)) in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state extra - | (Data.BuiltInPredicate.CInOut - ({ ContextualConversion.embed = embed; readback - }, - _, ffi), + | (Data.BuiltInPredicate.InOut + ({ Conversion.embed = embed; readback }, _, ffi), t::rest) -> let (state, i, gls) = inout_of_termC ~depth readback n bname ctx @@ -1816,112 +1784,78 @@ module FFI = (state, (ass @ l)) in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | (Data.BuiltInPredicate.In - ({ Conversion.readback = readback }, _, ffi), - t::rest) -> - let (state, i, gls) = - in_of_term ~depth readback n bname state t in - aux ffi ctx constraints ~compute:(compute i) - ~reduce rest (n + 1) state (gls :: extra) - | (Data.BuiltInPredicate.Out - ({ Conversion.embed = embed; readback }, _, ffi), - t::rest) -> - let i = - out_of_term ~depth readback n bname state t in - let reduce state (rest, out) = - let (state, l) = reduce state rest in - let (state, ass) = - mk_out_assign ~depth embed bname state i t - out in - (state, (ass @ l)) in - aux ffi ctx constraints ~compute:(compute i) - ~reduce rest (n + 1) state extra - | (Data.BuiltInPredicate.InOut - ({ Conversion.embed = embed; readback }, _, ffi), - t::rest) -> - let (state, i, gls) = - inout_of_term ~depth readback n bname state t in - let reduce state (rest, out) = - let (state, l) = reduce state rest in - let (state, ass) = - mk_inout_assign ~depth embed bname state i - t out in - (state, (ass @ l)) in - aux ffi ctx constraints ~compute:(compute i) - ~reduce rest (n + 1) state (gls :: extra) | (_, t::_) -> arity_err ~depth bname n (Some t) | (_, []) -> arity_err ~depth bname n None in - let rec aux_ctx : type i o h c. - (i, o, h, c) Data.BuiltInPredicate.ffi -> - (h, c) ContextualConversion.ctx_readback - = - function - | Data.BuiltInPredicate.Full (f, _) -> f - | Data.BuiltInPredicate.Read (f, _) -> f - | Data.BuiltInPredicate.VariadicIn (f, _, _) -> f - | Data.BuiltInPredicate.VariadicOut (f, _, _) -> f - | Data.BuiltInPredicate.VariadicInOut (f, _, _) -> f - | Data.BuiltInPredicate.Easy _ -> ContextualConversion.unit_ctx - | Data.BuiltInPredicate.In (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.Out (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.InOut (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.CIn (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.COut (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.CInOut (_, _, rest) -> aux_ctx rest in let reduce state _ = (state, []) in - let (state, ctx, csts, gls_ctx) = - aux_ctx ffi ~depth hyps constraints state in - let (state, gls) = aux ffi ctx csts ~compute ~reduce data 1 state [] in + let (state, ctx, gls_ctx) = in_ctx ~depth hyps constraints state in + let (state, gls) = + aux ffi ctx constraints ~compute ~reduce data 1 state [] in (state, (gls_ctx @ gls)) end -let rec embed_query_aux : type a. - mk_Arg:(State.t -> name:string -> args:term list -> (State.t * term)) -> +let embed_query_args ctx ~mk_Arg = + let rec aux : type a. depth:int -> predicate:constant -> term list -> - term list -> State.t -> a Query.arguments -> (State.t * term) - = - fun ~mk_Arg -> + term list -> + constraints -> + State.t -> (a, 'ctx) Query.arguments -> (State.t * term) + = fun ~depth -> fun ~predicate -> fun gls -> fun args -> - fun state -> - fun descr -> - match descr with - | Data.Query.D (d, x, rest) -> - let (state, x, glsx) = d.Conversion.embed ~depth state x in - embed_query_aux ~mk_Arg ~depth ~predicate (gls @ glsx) (x - :: args) state rest - | Data.Query.Q (d, name, rest) -> - let (state, x) = mk_Arg state ~name ~args:[] in - embed_query_aux ~mk_Arg ~depth ~predicate gls (x :: args) - state rest - | Data.Query.N -> - let args = List.rev args in - (state, - ((match gls with - | [] -> C.mkAppL predicate args - | gls -> - C.mkAppL Global_symbols.andc - (gls @ [C.mkAppL predicate args])))) -let embed_query ~mk_Arg ~depth state (Query.Query { predicate; arguments }) - = embed_query_aux ~mk_Arg ~depth ~predicate [] [] state arguments + fun constraints -> + fun state -> + fun descr -> + match descr with + | Data.Query.D (d, x, rest) -> + let (state, x, glsx) = + d.Conversion.embed ~depth ctx constraints state x in + aux ~depth ~predicate (gls @ glsx) (x :: args) + constraints state rest + | Data.Query.Q (d, name, rest) -> + let (state, x) = mk_Arg state ~name ~args:[] in + aux ~depth ~predicate gls (x :: args) constraints state + rest + | Data.Query.N -> + let args = List.rev args in + (state, + ((match gls with + | [] -> C.mkAppL predicate args + | gls -> + C.mkAppL Global_symbols.andc + (gls @ [C.mkAppL predicate args])))) in + aux let rec query_solution_aux : type a. - a Query.arguments -> term StrMap.t -> State.t -> a = + (a, 'ctx) Query.arguments -> + term StrMap.t -> 'ctx -> constraints -> State.t -> a + = fun args -> fun assignments -> - fun state -> - match args with - | Data.Query.N -> () - | Data.Query.D (_, _, args) -> - query_solution_aux args assignments state - | Data.Query.Q (d, name, args) -> - let x = StrMap.find name assignments in - let (state, x, _gls) = d.Conversion.readback ~depth:0 state x in - (x, (query_solution_aux args assignments state)) -let output arguments assignments state = - query_solution_aux arguments assignments state + fun ctx -> + fun constraints -> + fun state -> + match args with + | Data.Query.N -> () + | Data.Query.D (_, _, args) -> + query_solution_aux args assignments ctx constraints state + | Data.Query.Q (d, name, args) -> + let x = StrMap.find name assignments in + let (state, x, _gls) = + d.Conversion.readback ~depth:0 ctx constraints state x in + (x, + (query_solution_aux args assignments ctx constraints state)) +let output ctx arguments assignments constraints state = + query_solution_aux arguments assignments ctx constraints state +let embed_query ~mk_Arg ~depth hyps constraints state (Query.Query + ({ Query.context = context; predicate; arguments }, cc, builder)) = + let ctx_builder = + Data.Conversion.context_builder cc builder ((new Conversion.ctx) hyps) in + let (state, ctx_entries, ctx, gls) = + ctx_builder ~depth constraints context state in + ((embed_query_args ctx ~mk_Arg ~depth ~predicate gls [] constraints state + arguments), (output ctx arguments)) module Indexing = struct let mustbevariablec = min_int @@ -2754,7 +2688,7 @@ module Constraints : (let open State in ((init ()) |> (end_goal_compilation StrMap.empty)) |> end_compilation); - query_arguments = Query.N; + query_readback = (fun _ -> fun _ -> fun _ -> ()); symbol_table = (!C.table); builtins = (!FFI.builtins) } in @@ -3193,13 +3127,13 @@ open Mainloop let mk_outcome search get_cs assignments = try let alts = search () in - let (syn_csts, state, qargs, pp_ctx) = get_cs () in + let (syn_csts, state, readback_output, pp_ctx) = get_cs () in let solution = { assignments; constraints = syn_csts; state; - output = (output qargs assignments state); + output = (readback_output assignments syn_csts state); pp_ctx } in ((Success solution), alts) @@ -3212,7 +3146,7 @@ let execute_once ?max_steps ?delay_outside_fragment exec = (mk_outcome search (fun () -> ((get CS.Ugly.delayed), ((get CS.state) |> State.end_execution), - (exec.query_arguments), + (exec.query_readback), { Data.uv_names = (ref (get Pp.uv_names)); table = (get C.table) })) exec.assignments)) let execute_loop ?delay_outside_fragment exec ~more ~pp = @@ -3225,7 +3159,7 @@ let execute_loop ?delay_outside_fragment exec ~more ~pp = mk_outcome f (fun () -> ((get CS.Ugly.delayed), ((get CS.state) |> State.end_execution), - (exec.query_arguments), + (exec.query_readback), { Data.uv_names = (ref (get Pp.uv_names)); table = (get C.table) })) exec.assignments in let time1 = Unix.gettimeofday () in k := alts; pp (time1 -. time0) o in diff --git a/src/.ppcache/runtime_trace_off.mli b/src/.ppcache/runtime_trace_off.mli index 3e05312c9..1d471db5e 100644 --- a/src/.ppcache/runtime_trace_off.mli +++ b/src/.ppcache/runtime_trace_off.mli @@ -1,4 +1,4 @@ -(*e0914f3476d15e2ba79d82fa97efbbd05a6e4c75 *src/runtime_trace_off.mli --cookie elpi_trace="false"*) +(*dbd414a954857bee083d74bb49562a268062675f *src/runtime_trace_off.mli --cookie elpi_trace="false"*) #1 "src/runtime_trace_off.mli" open Util open Data @@ -18,7 +18,10 @@ end val pp_stuck_goal : ?pp_ctx:pp_ctx -> Fmt.formatter -> stuck_goal -> unit val embed_query : mk_Arg:(State.t -> name:string -> args:term list -> (State.t * term)) -> - depth:int -> State.t -> 'a Query.t -> (State.t * term) + depth:int -> + hyps -> + constraints -> + State.t -> 'a Query.t -> ((State.t * term) * 'a query_readback) val execute_once : ?max_steps:int -> ?delay_outside_fragment:bool -> 'a executable -> 'a outcome diff --git a/src/.ppcache/runtime_trace_on.ml b/src/.ppcache/runtime_trace_on.ml index eb3b76831..2c0752478 100644 --- a/src/.ppcache/runtime_trace_on.ml +++ b/src/.ppcache/runtime_trace_on.ml @@ -1,4 +1,4 @@ -(*25823e968f78a65500da52de3f79f1aeb00d2b5a *src/runtime_trace_on.ml --cookie elpi_trace="true"*) +(*3a434c451cdabf1a722d3fd2ed37b08e1240c2f9 *src/runtime_trace_on.ml --cookie elpi_trace="true"*) #1 "src/runtime_trace_on.ml" module Fmt = Format module F = Ast.Func @@ -2100,25 +2100,6 @@ module FFI = match deref_head ~depth t with | Discard -> Data.BuiltInPredicate.Discard | _ -> Data.BuiltInPredicate.Keep - let in_of_term ~depth readback n bname state t = - wrap_type_err bname n (readback ~depth state) t - let inout_of_term ~depth readback n bname state t = - wrap_type_err bname n (readback ~depth state) t - let mk_out_assign ~depth embed bname state input v output = - match (output, input) with - | (None, Data.BuiltInPredicate.Discard) -> (state, []) - | (Some _, Data.BuiltInPredicate.Discard) -> (state, []) - | (Some t, Data.BuiltInPredicate.Keep) -> - let (state, t, extra) = embed ~depth state t in - (state, (extra @ [App (Global_symbols.eqc, v, [t])])) - | (None, Data.BuiltInPredicate.Keep) -> (state, []) - let mk_inout_assign ~depth embed bname state input v output = - match output with - | None -> (state, []) - | Some t -> - let (state, t, extra) = - embed ~depth state (Data.BuiltInPredicate.Data t) in - (state, (extra @ [App (Global_symbols.eqc, v, [t])])) let in_of_termC ~depth readback n bname hyps constraints state t = wrap_type_err bname n (readback ~depth hyps constraints state) t let inout_of_termC = in_of_termC @@ -2147,12 +2128,12 @@ module FFI = | x::xs -> let (s, x, gls) = f s x in aux (x :: acc) (gls :: extra) s xs in aux [] [] s l - let call (Data.BuiltInPredicate.Pred (bname, ffi, compute)) ~depth hyps - constraints state data = - let rec aux : type i o h c. - (i, o, h, c) Data.BuiltInPredicate.ffi -> + let call (Data.BuiltInPredicate.Pred (bname, ffi, in_ctx, compute)) + ~depth hyps constraints state data = + let rec aux : type i o h. + (i, o, h) Data.BuiltInPredicate.ffi -> h -> - c -> + constraints -> compute:i -> reduce:(State.t -> o -> (State.t * extra_goals)) -> term list -> @@ -2194,10 +2175,8 @@ module FFI = ((let open List in concat (rev extra)) @ (gls @ (List.rev l)))) | (Data.BuiltInPredicate.VariadicIn - (_, - { ContextualConversion.readback = readback }, - _), - data) -> + ({ Conversion.readback = readback }, _), data) + -> let (state, i, gls) = map_acc (in_of_termC ~depth readback n bname ctx @@ -2210,10 +2189,7 @@ module FFI = (let open List in gls @ ((concat (rev extra)) @ (rev l)))) | (Data.BuiltInPredicate.VariadicOut - (_, - { ContextualConversion.embed = embed; readback - }, - _), + ({ Conversion.embed = embed; readback }, _), data) -> let i = List.map @@ -2238,10 +2214,7 @@ module FFI = (let open List in (concat (rev extra)) @ (rev l)))) | (Data.BuiltInPredicate.VariadicInOut - (_, - { ContextualConversion.embed = embed; readback - }, - _), + ({ Conversion.embed = embed; readback }, _), data) -> let (state, i, gls) = map_acc @@ -2267,19 +2240,16 @@ module FFI = (let open List in gls @ ((concat (rev extra)) @ (rev l))))) - | (Data.BuiltInPredicate.CIn - ({ ContextualConversion.readback = readback }, - _, ffi), + | (Data.BuiltInPredicate.In + ({ Conversion.readback = readback }, _, ffi), t::rest) -> let (state, i, gls) = in_of_termC ~depth readback n bname ctx constraints state t in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | (Data.BuiltInPredicate.COut - ({ ContextualConversion.embed = embed; readback - }, - _, ffi), + | (Data.BuiltInPredicate.Out + ({ Conversion.embed = embed; readback }, _, ffi), t::rest) -> let i = out_of_term ~depth readback n bname state t in @@ -2291,10 +2261,8 @@ module FFI = (state, (ass @ l)) in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state extra - | (Data.BuiltInPredicate.CInOut - ({ ContextualConversion.embed = embed; readback - }, - _, ffi), + | (Data.BuiltInPredicate.InOut + ({ Conversion.embed = embed; readback }, _, ffi), t::rest) -> let (state, i, gls) = inout_of_termC ~depth readback n bname ctx @@ -2307,112 +2275,78 @@ module FFI = (state, (ass @ l)) in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | (Data.BuiltInPredicate.In - ({ Conversion.readback = readback }, _, ffi), - t::rest) -> - let (state, i, gls) = - in_of_term ~depth readback n bname state t in - aux ffi ctx constraints ~compute:(compute i) - ~reduce rest (n + 1) state (gls :: extra) - | (Data.BuiltInPredicate.Out - ({ Conversion.embed = embed; readback }, _, ffi), - t::rest) -> - let i = - out_of_term ~depth readback n bname state t in - let reduce state (rest, out) = - let (state, l) = reduce state rest in - let (state, ass) = - mk_out_assign ~depth embed bname state i t - out in - (state, (ass @ l)) in - aux ffi ctx constraints ~compute:(compute i) - ~reduce rest (n + 1) state extra - | (Data.BuiltInPredicate.InOut - ({ Conversion.embed = embed; readback }, _, ffi), - t::rest) -> - let (state, i, gls) = - inout_of_term ~depth readback n bname state t in - let reduce state (rest, out) = - let (state, l) = reduce state rest in - let (state, ass) = - mk_inout_assign ~depth embed bname state i - t out in - (state, (ass @ l)) in - aux ffi ctx constraints ~compute:(compute i) - ~reduce rest (n + 1) state (gls :: extra) | (_, t::_) -> arity_err ~depth bname n (Some t) | (_, []) -> arity_err ~depth bname n None in - let rec aux_ctx : type i o h c. - (i, o, h, c) Data.BuiltInPredicate.ffi -> - (h, c) ContextualConversion.ctx_readback - = - function - | Data.BuiltInPredicate.Full (f, _) -> f - | Data.BuiltInPredicate.Read (f, _) -> f - | Data.BuiltInPredicate.VariadicIn (f, _, _) -> f - | Data.BuiltInPredicate.VariadicOut (f, _, _) -> f - | Data.BuiltInPredicate.VariadicInOut (f, _, _) -> f - | Data.BuiltInPredicate.Easy _ -> ContextualConversion.unit_ctx - | Data.BuiltInPredicate.In (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.Out (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.InOut (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.CIn (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.COut (_, _, rest) -> aux_ctx rest - | Data.BuiltInPredicate.CInOut (_, _, rest) -> aux_ctx rest in let reduce state _ = (state, []) in - let (state, ctx, csts, gls_ctx) = - aux_ctx ffi ~depth hyps constraints state in - let (state, gls) = aux ffi ctx csts ~compute ~reduce data 1 state [] in + let (state, ctx, gls_ctx) = in_ctx ~depth hyps constraints state in + let (state, gls) = + aux ffi ctx constraints ~compute ~reduce data 1 state [] in (state, (gls_ctx @ gls)) end -let rec embed_query_aux : type a. - mk_Arg:(State.t -> name:string -> args:term list -> (State.t * term)) -> +let embed_query_args ctx ~mk_Arg = + let rec aux : type a. depth:int -> predicate:constant -> term list -> - term list -> State.t -> a Query.arguments -> (State.t * term) - = - fun ~mk_Arg -> + term list -> + constraints -> + State.t -> (a, 'ctx) Query.arguments -> (State.t * term) + = fun ~depth -> fun ~predicate -> fun gls -> fun args -> - fun state -> - fun descr -> - match descr with - | Data.Query.D (d, x, rest) -> - let (state, x, glsx) = d.Conversion.embed ~depth state x in - embed_query_aux ~mk_Arg ~depth ~predicate (gls @ glsx) (x - :: args) state rest - | Data.Query.Q (d, name, rest) -> - let (state, x) = mk_Arg state ~name ~args:[] in - embed_query_aux ~mk_Arg ~depth ~predicate gls (x :: args) - state rest - | Data.Query.N -> - let args = List.rev args in - (state, - ((match gls with - | [] -> C.mkAppL predicate args - | gls -> - C.mkAppL Global_symbols.andc - (gls @ [C.mkAppL predicate args])))) -let embed_query ~mk_Arg ~depth state (Query.Query { predicate; arguments }) - = embed_query_aux ~mk_Arg ~depth ~predicate [] [] state arguments + fun constraints -> + fun state -> + fun descr -> + match descr with + | Data.Query.D (d, x, rest) -> + let (state, x, glsx) = + d.Conversion.embed ~depth ctx constraints state x in + aux ~depth ~predicate (gls @ glsx) (x :: args) + constraints state rest + | Data.Query.Q (d, name, rest) -> + let (state, x) = mk_Arg state ~name ~args:[] in + aux ~depth ~predicate gls (x :: args) constraints state + rest + | Data.Query.N -> + let args = List.rev args in + (state, + ((match gls with + | [] -> C.mkAppL predicate args + | gls -> + C.mkAppL Global_symbols.andc + (gls @ [C.mkAppL predicate args])))) in + aux let rec query_solution_aux : type a. - a Query.arguments -> term StrMap.t -> State.t -> a = + (a, 'ctx) Query.arguments -> + term StrMap.t -> 'ctx -> constraints -> State.t -> a + = fun args -> fun assignments -> - fun state -> - match args with - | Data.Query.N -> () - | Data.Query.D (_, _, args) -> - query_solution_aux args assignments state - | Data.Query.Q (d, name, args) -> - let x = StrMap.find name assignments in - let (state, x, _gls) = d.Conversion.readback ~depth:0 state x in - (x, (query_solution_aux args assignments state)) -let output arguments assignments state = - query_solution_aux arguments assignments state + fun ctx -> + fun constraints -> + fun state -> + match args with + | Data.Query.N -> () + | Data.Query.D (_, _, args) -> + query_solution_aux args assignments ctx constraints state + | Data.Query.Q (d, name, args) -> + let x = StrMap.find name assignments in + let (state, x, _gls) = + d.Conversion.readback ~depth:0 ctx constraints state x in + (x, + (query_solution_aux args assignments ctx constraints state)) +let output ctx arguments assignments constraints state = + query_solution_aux arguments assignments ctx constraints state +let embed_query ~mk_Arg ~depth hyps constraints state (Query.Query + ({ Query.context = context; predicate; arguments }, cc, builder)) = + let ctx_builder = + Data.Conversion.context_builder cc builder ((new Conversion.ctx) hyps) in + let (state, ctx_entries, ctx, gls) = + ctx_builder ~depth constraints context state in + ((embed_query_args ctx ~mk_Arg ~depth ~predicate gls [] constraints state + arguments), (output ctx arguments)) module Indexing = struct let mustbevariablec = min_int @@ -3445,7 +3379,7 @@ module Constraints : (let open State in ((init ()) |> (end_goal_compilation StrMap.empty)) |> end_compilation); - query_arguments = Query.N; + query_readback = (fun _ -> fun _ -> fun _ -> ()); symbol_table = (!C.table); builtins = (!FFI.builtins) } in @@ -4282,13 +4216,13 @@ open Mainloop let mk_outcome search get_cs assignments = try let alts = search () in - let (syn_csts, state, qargs, pp_ctx) = get_cs () in + let (syn_csts, state, readback_output, pp_ctx) = get_cs () in let solution = { assignments; constraints = syn_csts; state; - output = (output qargs assignments state); + output = (readback_output assignments syn_csts state); pp_ctx } in ((Success solution), alts) @@ -4301,7 +4235,7 @@ let execute_once ?max_steps ?delay_outside_fragment exec = (mk_outcome search (fun () -> ((get CS.Ugly.delayed), ((get CS.state) |> State.end_execution), - (exec.query_arguments), + (exec.query_readback), { Data.uv_names = (ref (get Pp.uv_names)); table = (get C.table) })) exec.assignments)) let execute_loop ?delay_outside_fragment exec ~more ~pp = @@ -4314,7 +4248,7 @@ let execute_loop ?delay_outside_fragment exec ~more ~pp = mk_outcome f (fun () -> ((get CS.Ugly.delayed), ((get CS.state) |> State.end_execution), - (exec.query_arguments), + (exec.query_readback), { Data.uv_names = (ref (get Pp.uv_names)); table = (get C.table) })) exec.assignments in let time1 = Unix.gettimeofday () in k := alts; pp (time1 -. time0) o in diff --git a/src/.ppcache/runtime_trace_on.mli b/src/.ppcache/runtime_trace_on.mli index edd347e46..3b5372e13 100644 --- a/src/.ppcache/runtime_trace_on.mli +++ b/src/.ppcache/runtime_trace_on.mli @@ -1,4 +1,4 @@ -(*e0914f3476d15e2ba79d82fa97efbbd05a6e4c75 *src/runtime_trace_on.mli --cookie elpi_trace="true"*) +(*dbd414a954857bee083d74bb49562a268062675f *src/runtime_trace_on.mli --cookie elpi_trace="true"*) #1 "src/runtime_trace_on.mli" open Util open Data @@ -18,7 +18,10 @@ end val pp_stuck_goal : ?pp_ctx:pp_ctx -> Fmt.formatter -> stuck_goal -> unit val embed_query : mk_Arg:(State.t -> name:string -> args:term list -> (State.t * term)) -> - depth:int -> State.t -> 'a Query.t -> (State.t * term) + depth:int -> + hyps -> + constraints -> + State.t -> 'a Query.t -> ((State.t * term) * 'a query_readback) val execute_once : ?max_steps:int -> ?delay_outside_fragment:bool -> 'a executable -> 'a outcome diff --git a/src/API.ml b/src/API.ml index 9e78265da..f4fc578e0 100644 --- a/src/API.ml +++ b/src/API.ml @@ -46,7 +46,6 @@ let init ~builtins ~basedir:cwd argv = List.fold_left (fun state -> function | Data.BuiltInPredicate.MLCode (p,_) -> Compiler.Builtins.register state p | Data.BuiltInPredicate.MLData _ -> state - | Data.BuiltInPredicate.MLDataC _ -> state | Data.BuiltInPredicate.LPCode _ -> state | Data.BuiltInPredicate.LPDoc _ -> state) state decls) state builtins in let header = @@ -120,6 +119,7 @@ module Data = struct type constraints = Data.constraints type state = Data.State.t type pretty_printer_context = ED.pp_ctx + type constant = Data.constant module StrMap = Util.StrMap type 'a solution = 'a Data.solution = { assignments : term StrMap.t; @@ -133,6 +133,9 @@ module Data = struct hsrc : term } type hyps = hyp list + module Constants = struct + module Map = Data.Constants.Map + end end module Compile = struct @@ -203,11 +206,15 @@ end module Conversion = struct type extra_goals = ED.extra_goals include ED.Conversion -end -module ContextualConversion = ED.ContextualConversion + let (^^) t = { t with + embed = (fun ~depth h c s x -> t.embed ~depth (new ctx h#raw) c s x); + readback = (fun ~depth h c s x -> t.readback ~depth (new ctx h#raw) c s x); + } + +end -module RawOpaqueData = struct +module OpaqueData = struct include Util.CData include ED.C @@ -216,6 +223,7 @@ module RawOpaqueData = struct type 'a declaration = { name : name; + cname : name; doc : doc; pp : Format.formatter -> 'a -> unit; compare : 'a -> 'a -> int; @@ -224,166 +232,89 @@ module RawOpaqueData = struct constants : (name * 'a) list; (* global constants of that type, eg "std_in" *) } - let conversion_of_cdata ~name ?(doc="") ~constants_map ~constants - { cin; isc; cout; name=c } - = - let ty = Conversion.TyName name in - let embed ~depth:_ state x = - state, ED.Term.CData (cin x), [] in - let readback ~depth state t = - let module R = (val !r) in let open R in - match R.deref_head ~depth t with - | ED.Term.CData c when isc c -> state, cout c, [] - | ED.Term.Const i as t when i < 0 -> - begin try state, ED.Constants.Map.find i constants_map, [] - with Not_found -> raise (Conversion.TypeErr(ty,depth,t)) end - | t -> raise (Conversion.TypeErr(ty,depth,t)) in - let pp_doc fmt () = + type 'a cdata_with_constants = + 'a cdata * name * (string * 'a) ED.Constants.Map.t * doc + + let rest ({ cin; name=c; },name,constants_map,doc) = + Conversion.TyName name, + (fun fmt x -> pp fmt (cin x)), + fun fmt () -> let module R = (val !r) in let open R in if doc <> "" then begin ED.BuiltInPredicate.pp_comment fmt ("% " ^ doc); Format.fprintf fmt "@\n"; end; Format.fprintf fmt "@[typeabbrev %s (ctype \"%s\").@]@\n@\n" name c; - List.iter (fun (c,_) -> + ED.Constants.Map.iter (fun _ (c,_) -> Format.fprintf fmt "@[type %s %s.@]@\n" c name) - constants - in - { Conversion.embed; readback; ty; pp_doc; pp = (fun fmt x -> pp fmt (cin x)) } + constants_map - let conversion_of_cdata ~name ?doc ?(constants=[]) cd = + let embed ({ cin; _ },_,_,_) = (); fun ~depth:_ _ _ state x -> + state, ED.Term.CData (cin x), [] + let readback ({ isc; cout; _ },name,constants_map,_)= (); fun ~depth _ _ state t -> let module R = (val !r) in let open R in - let constants_map = + match R.deref_head ~depth t with + | ED.Term.CData c when isc c -> state, cout c, [] + | ED.Term.Const i as t when i < 0 -> + begin try state, snd @@ ED.Constants.Map.find i constants_map, [] + with Not_found -> raise (Conversion.TypeErr(Conversion.TyName name,depth,t)) end + | t -> raise (Conversion.TypeErr(Conversion.TyName name,depth,t)) + + let declare_cdata cdata name doc constants = + let cd_w_consts = + cdata, name, List.fold_right (fun (n,v) -> - ED.Constants.Map.add (ED.Global_symbols.declare_global_symbol n) v) - constants ED.Constants.Map.empty in - conversion_of_cdata ~name ?doc ~constants_map ~constants cd + ED.Constants.Map.add (ED.Global_symbols.declare_global_symbol n) (n,v)) + constants ED.Constants.Map.empty, doc in + let ty, pp, pp_doc = rest cd_w_consts in + ty, pp, pp_doc, cd_w_consts - let declare { name; doc; pp; compare; hash; hconsed; constants; } = - let cdata = declare { + let declare { name; cname; doc; pp; compare; hash; hconsed; constants; } = + let c = declare { data_compare = compare; data_pp = pp; data_hash = hash; - data_name = name; + data_name = cname; data_hconsed = hconsed; - } in - cdata, conversion_of_cdata ~name ~doc ~constants cdata + } in + declare_cdata c name doc constants end -module OpaqueData = struct - - type name = string - type doc = string - - type 'a declaration = 'a RawOpaqueData.declaration = { - name : name; - doc : doc; - pp : Format.formatter -> 'a -> unit; - compare : 'a -> 'a -> int; - hash : 'a -> int; - hconsed : bool; - constants : (name * 'a) list; (* global constants of that type, eg "std_in" *) - } - - let declare x = snd @@ RawOpaqueData.declare x - -end - -module BuiltInData = struct - - let int = RawOpaqueData.conversion_of_cdata ~name:"int" ED.C.int - let float = RawOpaqueData.conversion_of_cdata ~name:"float" ED.C.float - let string = RawOpaqueData.conversion_of_cdata ~name:"string" ED.C.string - let loc = RawOpaqueData.conversion_of_cdata ~name:"loc" ED.C.loc - let poly ty = - let embed ~depth:_ state x = state, x, [] in - let readback ~depth state t = state, t, [] in - { Conversion.embed; readback; ty = Conversion.TyName ty; - pp = (fun fmt _ -> Format.fprintf fmt ""); - pp_doc = (fun fmt () -> ()) } - - let any = poly "any" - - let fresh_copy t depth = - let module R = (val !r) in let open R in - let open ED in - let rec aux d t = - match deref_head ~depth:(depth + d) t with - | Lam t -> mkLam (aux (d+1) t) - | Const c as x -> - if c < 0 || c >= depth then x - else raise Conversion.(TypeErr(TyName"closed term",depth+d,x)) - | App (c,x,xs) -> - if c < 0 || c >= depth then mkApp c (aux d x) (List.map (aux d) xs) - else raise Conversion.(TypeErr(TyName"closed term",depth+d,x)) - | (UVar _ | AppUVar _) as x -> - raise Conversion.(TypeErr(TyName"closed term",depth+d,x)) - | Arg _ | AppArg _ -> assert false - | Builtin (c,xs) -> mkBuiltin c (List.map (aux d) xs) - | CData _ as x -> x - | Cons (hd,tl) -> mkCons (aux d hd) (aux d tl) - | Nil as x -> x - | Discard as x -> x - in - (aux 0 t, depth) +module RawOpaqueData = struct + include Util.CData + include ED.C - let closed ty = - let ty = Conversion.(TyName ty) in - let embed ~depth state (x,from) = - let module R = (val !r) in let open R in - state, R.hmove ~from ~to_:depth ?avoid:None x, [] in - let readback ~depth state t = - state, fresh_copy t depth, [] in - { Conversion.embed; readback; ty; - pp = (fun fmt (t,d) -> - let module R = (val !r) in let open R in - R.Pp.uppterm d [] d ED.empty_env fmt t); - pp_doc = (fun fmt () -> ()) } - - let map_acc f s l = - let rec aux acc extra s = function - | [] -> s, List.rev acc, List.(concat (rev extra)) - | x :: xs -> - let s, x, gls = f s x in - aux (x :: acc) (gls :: extra) s xs - in - aux [] [] s l + let cdata (c,_,_,_) = c + + let { cin = of_char; isc = is_char; cout = to_char } as char = declare { + data_compare = Pervasives.compare; + data_pp = (fun fmt c -> Format.fprintf fmt "%c" c); + data_hash = Hashtbl.hash; + data_name = "char"; + data_hconsed = false; + } + let of_char x = ED.mkCData (of_char x) + + let { cin = of_out_stream; isc = is_out_stream; cout = to_out_stream } as out_stream = declare { + data_compare = (fun (_,s1) (_,s2) -> String.compare s1 s2); + data_pp = (fun fmt (_,d) -> Format.fprintf fmt "" d); + data_hash = (fun (x,_) -> Hashtbl.hash x); + data_name = "out_stream"; + data_hconsed = false; + } + let of_out_stream x = ED.mkCData (of_out_stream x) + + let { cin = of_in_stream; isc = is_in_stream; cout = to_in_stream } as in_stream = declare { + data_compare = (fun (_,s1) (_,s2) -> String.compare s1 s2); + data_pp = (fun fmt (_,d) -> Format.fprintf fmt "" d); + data_hash = (fun (x,_) -> Hashtbl.hash x); + data_name = "in_stream"; + data_hconsed = false; + } + let of_in_stream x = ED.mkCData (of_in_stream x) - let listC d = - let embed ~depth h c s l = - let module R = (val !r) in let open R in - let s, l, eg = map_acc (d.ContextualConversion.embed ~depth h c) s l in - s, list_to_lp_list l, eg in - let readback ~depth h c s t = - let module R = (val !r) in let open R in - map_acc (d.ContextualConversion.readback ~depth h c) s - (lp_list_to_list ~depth t) - in - let pp fmt l = - Format.fprintf fmt "[%a]" (Util.pplist d.pp ~boxed:true "; ") l in - { ContextualConversion.embed; readback; - ty = TyApp ("list",d.ty,[]); - pp; - pp_doc = (fun fmt () -> ()) } - - let list d = - let embed ~depth s l = - let module R = (val !r) in let open R in - let s, l, eg = map_acc (d.Conversion.embed ~depth) s l in - s, list_to_lp_list l, eg in - let readback ~depth s t = - let module R = (val !r) in let open R in - map_acc (d.Conversion.readback ~depth) s - (lp_list_to_list ~depth t) - in - let pp fmt l = - Format.fprintf fmt "[%a]" (Util.pplist d.pp ~boxed:true "; ") l in - { Conversion.embed; readback; - ty = TyApp ("list",d.ty,[]); - pp; - pp_doc = (fun fmt () -> ()) } end @@ -530,16 +461,8 @@ module RawData = struct let of_term x = x - let of_hyps x = x - - type hyp = Data.hyp = { - hdepth : int; - hsrc : term - } - type hyps = hyp list - type suspended_goal = ED.suspended_goal = { - context : hyps; + context : Data.hyps; goal : int * term } @@ -665,8 +588,8 @@ module FlexibleData = struct Conversion.ty = Conversion.TyName "uvar"; pp_doc = (fun fmt () -> Format.fprintf fmt "Unification variable, as the uvar keyword"); pp = (fun fmt (k,_) -> Format.fprintf fmt "%a" Elpi.pp k); - embed = (fun ~depth s (k,args) -> s, RawData.mkUnifVar k ~args s, []); - readback = (fun ~depth state t -> + embed = (fun ~depth _ _ s (k,args) -> s, RawData.mkUnifVar k ~args s, []); + readback = (fun ~depth _ _ state t -> match RawData.look ~depth t with | RawData.UnifVar(k,args) -> state, (k,args), [] @@ -675,6 +598,225 @@ module FlexibleData = struct end +module BuiltIn = struct + include ED.BuiltInPredicate + let declare ~file_name l = file_name, l + let document_fmt fmt (_,l) = + ED.BuiltInPredicate.document fmt l + let document_file ?(header="") (name,l) = + let oc = open_out name in + let fmt = Format.formatter_of_out_channel oc in + Format.fprintf fmt "%s%!" header; + ED.BuiltInPredicate.document fmt l; + Format.pp_print_flush fmt (); + close_out oc +end + +module BuiltInData = struct + + let ty, pp, pp_doc, int = OpaqueData.declare_cdata RawOpaqueData.int "int" "" [] + let int : 'h. (int, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed int ~depth); + readback = (fun ~depth -> OpaqueData.readback int ~depth); + } + + let ty, pp, pp_doc, float = OpaqueData.declare_cdata RawOpaqueData.float "float" "" [] + let float : 'h. (float, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed float ~depth); + readback = (fun ~depth -> OpaqueData.readback float ~depth); + } + + let ty, pp, pp_doc, string = OpaqueData.declare_cdata RawOpaqueData.string "string" "" [] + let string : 'h. (string, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed string ~depth); + readback = (fun ~depth -> OpaqueData.readback string ~depth); + } + + let ty, pp, pp_doc, loc = OpaqueData.declare_cdata RawOpaqueData.loc "loc" "" [] + let loc : 'h. (Util.Loc.t, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed loc ~depth); + readback = (fun ~depth -> OpaqueData.readback loc ~depth); + } + + let ty, pp, pp_doc, char = OpaqueData.declare_cdata RawOpaqueData.char "char" "an octect" [] + let char : 'h. (char, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed char ~depth); + readback = (fun ~depth -> OpaqueData.readback char ~depth); + } + + let ty, pp, pp_doc, in_stream = OpaqueData.declare_cdata RawOpaqueData.in_stream "in_stream" "" ["std_in",(stdin,"stdin")] + let in_stream : 'h. (in_channel * string, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed in_stream ~depth); + readback = (fun ~depth -> OpaqueData.readback in_stream ~depth); + } + + let ty, pp, pp_doc, out_stream = OpaqueData.declare_cdata RawOpaqueData.out_stream "out_stream" "" ["std_out",(stdout,"stdout");"std_err",(stderr,"stderr")] + let out_stream : 'h. (out_channel * string, 'h) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed out_stream ~depth); + readback = (fun ~depth -> OpaqueData.readback out_stream ~depth); + } + + let poly ty = + let embed ~depth:_ _ _ state x = state, x, [] in + let readback ~depth _ _ state t = state, t, [] in + { Conversion.embed; readback; ty = Conversion.TyName ty; + pp = (fun fmt _ -> Format.fprintf fmt ""); + pp_doc = (fun fmt () -> ()) } + + let any = + let embed ~depth:_ _ _ state x = state, x, [] in + let readback ~depth _ _ state t = state, t, [] in + { Conversion.embed; readback; ty = Conversion.TyName "any"; + pp = (fun fmt _ -> Format.fprintf fmt ""); + pp_doc = (fun fmt () -> ()) } + + let nominal = + let embed ~depth:_ _ _ state x = + let module R = (val !r) in let open R in + if x < 0 then Util.type_error "not a bound variable"; + state, R.mkConst x, [] in + let readback ~depth _ _ state t = + let module R = (val !r) in let open R in + match deref_head ~depth t with + | ED.Const i when i >= 0 -> state, i, [] + | _ -> Util.type_error "not a bound variable" in + { Conversion.embed; readback; ty = TyName "nominal"; + pp = (fun fmt d -> Format.fprintf fmt "%d" d); + pp_doc = (fun fmt () -> ()) } + + let fresh_copy t depth = + let module R = (val !r) in let open R in + let open ED in + let rec aux d t = + match deref_head ~depth:(depth + d) t with + | Lam t -> mkLam (aux (d+1) t) + | Const c as x -> + if c < 0 || c >= depth then x + else raise Conversion.(TypeErr(TyName"closed term",depth+d,x)) + | App (c,x,xs) -> + if c < 0 || c >= depth then mkApp c (aux d x) (List.map (aux d) xs) + else raise Conversion.(TypeErr(TyName"closed term",depth+d,x)) + | (UVar _ | AppUVar _) as x -> + raise Conversion.(TypeErr(TyName"closed term",depth+d,x)) + | Arg _ | AppArg _ -> assert false + | Builtin (c,xs) -> mkBuiltin c (List.map (aux d) xs) + | CData _ as x -> x + | Cons (hd,tl) -> mkCons (aux d hd) (aux d tl) + | Nil as x -> x + | Discard as x -> x + in + (aux 0 t, depth) + + let closed ty = + let ty = Conversion.(TyName ty) in + let embed ~depth _ _ state (x,from) = + let module R = (val !r) in let open R in + state, R.hmove ~from ~to_:depth ?avoid:None x, [] in + let readback ~depth _ _ state t = + state, fresh_copy t depth, [] in + { Conversion.embed; readback; ty; + pp = (fun fmt (t,d) -> + let module R = (val !r) in let open R in + R.Pp.uppterm d [] d ED.empty_env fmt t); + pp_doc = (fun fmt () -> ()) } + + let map_acc f s l = + let rec aux acc extra s = function + | [] -> s, List.rev acc, List.(concat (rev extra)) + | x :: xs -> + let s, x, gls = f s x in + aux (x :: acc) (gls :: extra) s xs + in + aux [] [] s l + + let embed_list d ~depth h c s l = + let module R = (val !r) in let open R in + let s, l, eg = map_acc (d ~depth h c) s l in + s, list_to_lp_list l, eg + let readback_list d ~depth h c s t = + let module R = (val !r) in let open R in + map_acc (d ~depth h c) s + (lp_list_to_list ~depth t) + + let list d = + let pp fmt l = + Format.fprintf fmt "[%a]" (Util.pplist d.Conversion.pp ~boxed:true "; ") l in + { Conversion.embed = embed_list d.Conversion.embed; readback = readback_list d.Conversion.readback; + ty = TyApp ("list",d.ty,[]); + pp; + pp_doc = (fun fmt () -> ()) } + + let ttc = ED.Global_symbols.declare_global_symbol "tt" + let ffc = ED.Global_symbols.declare_global_symbol "ff" + let readback_bool ~depth h c s t = + let module R = (val !r) in let open R in + match R.deref_head ~depth t with + | ED.Const c when c == ttc -> s, true, [] + | ED.Const c when c == ffc -> s, false, [] + | _ -> raise (Conversion.(TypeErr(TyName "bool",depth,t))) + let embed_bool ~depth h c s t = + let module R = (val !r) in let open R in + match t with + | true -> s, R.mkConst ttc, [] + | false -> s, R.mkConst ffc, [] + + let bool : 'c. (bool, #Conversion.ctx as 'c) Conversion.t = { + Conversion.ty = Conversion.TyName "bool"; + pp_doc = (fun fmt () -> + ED.BuiltInPredicate.ADT.document_adt + "Boolean values: tt and ff since true and false are predicates" + Conversion.(TyName "bool") + ["tt","",["bool"];"ff","",["bool"]] fmt ()); + pp = (fun fmt b -> Format.fprintf fmt "%b" b); + embed = embed_bool; + readback = readback_bool; + } + + type diagnostic = OK | ERROR of string BuiltIn.ioarg + let mkOK = OK + let mkERROR s = ERROR (Data s) + + let okc = ED.Global_symbols.declare_global_symbol "ok" + let errorc = ED.Global_symbols.declare_global_symbol "error" + + let readback_diagnostic ~depth h c s t = + let module R = (val !r) in let open R in + match R.deref_head ~depth t with + | ED.Const c when c == okc -> s, OK, [] + | ED.App(c,x,[]) when c == errorc -> + begin match R.deref_head ~depth x with + | ED.UVar _ | ED.AppUVar _ + | ED.Discard -> s, ERROR NoData, [] + | ED.CData c when RawOpaqueData.is_string c -> + s, ERROR (Data (RawOpaqueData.to_string c)), [] + | _ -> raise (Conversion.(TypeErr(TyName "diagnostic",depth,t))) + end + | _ -> raise (Conversion.(TypeErr(TyName "diagnostic",depth,t))) + + let embed_diagnostic ~depth h c s t = + let module R = (val !r) in let open R in + match t with + | OK -> s, R.mkConst okc, [] + | ERROR NoData -> assert false + | ERROR (Data d) -> s, ED.mkApp errorc (RawOpaqueData.of_string d) [], [] + + let diagnostic = { + Conversion.ty = TyName "diagnostic"; + pp_doc = (fun fmt () -> + ED.BuiltInPredicate.ADT.document_adt + "Used in builtin variants that return Coq's error rather than failing" + Conversion.(TyName "diagnostic") + ["ok","Success",["diagnostic"];"error","Failure",["string";"diagnostic"]] fmt ()); + pp = (fun fmt -> function + | OK -> Format.fprintf fmt "OK" + | ERROR NoData -> Format.fprintf fmt "ERROR _" + | ERROR (Data s) -> Format.fprintf fmt "ERROR %S" s); + embed = embed_diagnostic; + readback = readback_diagnostic; + } + +end + module AlgebraicData = struct include ED.BuiltInPredicate.ADT type name = string @@ -696,7 +838,7 @@ module BuiltInPredicate = struct let mkData x = Data x - let ioargC a = let open ContextualConversion in { a with + let ioarg a = let open Conversion in { a with pp = (fun fmt -> function Data x -> a.pp fmt x | NoData -> Format.fprintf fmt "_"); embed = (fun ~depth hyps csts state -> function | Data x -> a.embed ~depth hyps csts state x @@ -710,18 +852,15 @@ module BuiltInPredicate = struct | _ -> let state, x, gls = a.readback ~depth hyps csts state t in state, mkData x, gls); } - let ioarg a = - let open ContextualConversion in - !< (ioargC (!> a)) let ioarg_any = let open Conversion in { BuiltInData.any with pp = (fun fmt -> function | Data x -> BuiltInData.any.pp fmt x | NoData -> Format.fprintf fmt "_"); - embed = (fun ~depth state -> function + embed = (fun ~depth _ _ state -> function | Data x -> state, x, [] | NoData -> assert false); - readback = (fun ~depth state t -> + readback = (fun ~depth _ _ state t -> let module R = (val !r) in match R.deref_head ~depth t with | ED.Term.Discard -> state, NoData, [] @@ -738,33 +877,27 @@ module BuiltInPredicate = struct end end -module BuiltIn = struct - include ED.BuiltInPredicate - let declare ~file_name l = file_name, l - let document_fmt fmt (_,l) = - ED.BuiltInPredicate.document fmt l - let document_file ?(header="") (name,l) = - let oc = open_out name in - let fmt = Format.formatter_of_out_channel oc in - Format.fprintf fmt "%s%!" header; - ED.BuiltInPredicate.document fmt l; - Format.pp_print_flush fmt (); - close_out oc -end - module Query = struct type name = string - type 'f arguments = 'f ED.Query.arguments = - | N : unit arguments - | D : 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q : 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments - - type 'x t = Query of { predicate : name; arguments : 'x arguments } + type ('f,'c) arguments = ('f,'c) ED.Query.arguments = + | N : (unit,'c) arguments + | D : ('a, #Conversion.ctx as 'c) Conversion.t * 'a * ('x,'c) arguments -> ('x,'c) arguments + | Q : ('a, #Conversion.ctx as 'c) Conversion.t * name * ('x,'c) arguments -> ('a * 'x,'c) arguments + + type 'c obj_builder = Data.state -> 'c + constraint 'c = #Conversion.ctx + + type _ t = Query : ('a,'x,'c) query_contents * ('a,'k,Conversion.ctx) Conversion.context * 'c obj_builder -> 'x t + and ('a,'x,'c) query_contents = { + context : 'a list; + predicate : string; + arguments : ('x,'c) arguments; + } - let compile (state,p) loc (Query { predicate; arguments }) = + let compile (state,p) loc (Query({ predicate; arguments; context }, cc, obj)) = let state, predicate = Compiler.Symbols.allocate_global_symbol_str state predicate in - let q = ED.Query.Query{ predicate; arguments } in + let q = ED.Query.(Query({ predicate; arguments;context },cc, obj)) in Compiler.query_of_data state p loc q end @@ -785,6 +918,8 @@ end module RawQuery = struct let mk_Arg = Compiler.mk_Arg let is_Arg = Compiler.is_Arg + type 'a query_readback = + Data.term Data.StrMap.t -> Data.constraints -> State.t -> 'a let compile (state,p) f = Compiler.query_of_term state p f end @@ -837,6 +972,8 @@ module Utils = struct let type_error = Util.type_error let anomaly = Util.anomaly let warn = Util.warn + let printf = Util.printf + let eprintf = Util.eprintf let clause_of_term ?name ?graft ~depth loc term = let open EA in @@ -912,3 +1049,65 @@ module RawPp = struct let show_term = ED.show_term end end + +module PPX = struct + +module Doc = struct + + let comment = ED.BuiltInPredicate.pp_comment + let kind fmt ty ~doc = ED.BuiltInPredicate.ADT.document_kind fmt ty doc + let constructor fmt ~name ~doc ~ty ~args = + ED.BuiltInPredicate.ADT.document_constructor + fmt name doc (List.map ED.Conversion.show_ty_ast (args @ [ty])) + let adt ~doc ~ty ~args = + ED.BuiltInPredicate.ADT.document_adt doc ty + (List.map (fun (n,s,a) -> n,s,List.map ED.Conversion.show_ty_ast (a@[ty])) args) + let show_ty_ast = ED.Conversion.show_ty_ast +end + + let readback_int ~depth _ c s x = BuiltInData.int.Conversion.readback ~depth (new Conversion.ctx []) c s x + let readback_float ~depth _ c s x = BuiltInData.float.Conversion.readback ~depth (new Conversion.ctx []) c s x + let readback_string ~depth _ c s x = BuiltInData.string.Conversion.readback ~depth (new Conversion.ctx []) c s x + let readback_list = BuiltInData.readback_list + let readback_loc ~depth _ c s x = BuiltInData.loc.Conversion.readback ~depth (new Conversion.ctx []) c s x + let readback_nominal ~depth _ c s x = BuiltInData.nominal.Conversion.readback ~depth (new Conversion.ctx []) c s x + + let embed_int ~depth _ c s x = BuiltInData.int.Conversion.embed ~depth (new Conversion.ctx []) c s x + let embed_float ~depth _ c s x = BuiltInData.float.Conversion.embed ~depth (new Conversion.ctx []) c s x + let embed_string ~depth _ c s x = BuiltInData.string.Conversion.embed ~depth (new Conversion.ctx []) c s x + let embed_list = BuiltInData.embed_list + let embed_loc ~depth _ c s x = BuiltInData.loc.Conversion.embed ~depth (new Conversion.ctx []) c s x + let embed_nominal ~depth _ c s x = BuiltInData.nominal.Conversion.embed ~depth (new Conversion.ctx []) c s x + type context_description = + | C : ('a,'k,'c) Conversion.context -> context_description + + let readback_context { Conversion.conv; to_key; push; is_entry_for_nominal; init} ctx ~depth hyps constraints state = + let module CMap = RawData.Constants.Map in + let filtered_hyps = + List.fold_left (fun m hyp -> + match is_entry_for_nominal hyp with + | None -> m + | Some idx -> + if CMap.mem idx m then + Utils.type_error "more than one context entry for the same nominal"; + CMap.add idx hyp m) CMap.empty + hyps in + let rec aux state gls i = + if i = depth then state, List.concat (List.rev gls) + else + if not (CMap.mem i filtered_hyps) then aux state gls (i + 1) + else + let hyp = CMap.find i filtered_hyps in + let hyp_depth = hyp.Data.hdepth in + let state, (nominal, t), gls_t = + conv.Conversion.readback + ~depth:hyp_depth ctx constraints state hyp.Data.hsrc in + assert (nominal = i); + let s = to_key ~depth:hyp_depth t in + let state = + push ~depth:i state s { Conversion.entry = t; depth = hyp_depth } in + aux state (gls_t :: gls) (i + 1) in + let state = init state in + aux state [] 0 + +end \ No newline at end of file diff --git a/src/API.mli b/src/API.mli index b73fe7ea7..95358de32 100644 --- a/src/API.mli +++ b/src/API.mli @@ -116,9 +116,23 @@ module Data : sig } (* Hypothetical context *) - type hyp + type hyp = { + hdepth : int; + hsrc : term + } type hyps = hyp list + type constant = int + module Constants : sig + + module Map : sig + include Map.S with type key = constant + val show : (Format.formatter -> 'a -> unit) -> 'a t -> string + val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + end + + end + end module Compile : sig @@ -230,92 +244,62 @@ end module Conversion : sig type ty_ast = TyName of string | TyApp of string * ty_ast * ty_ast list - type extra_goals = Data.term list + exception TypeErr of ty_ast * int * Data.term (* a type error at data conversion time *) - type 'a embedding = - depth:int -> + class ctx : Data.hyps -> + object + method raw : Data.hyps + end + + type ('a,'c) embedding = + depth:int -> 'c -> Data.constraints -> Data.state -> 'a -> Data.state * Data.term * extra_goals + constraint 'c = #ctx - type 'a readback = - depth:int -> + type ('a,'c) readback = + depth:int -> 'c -> Data.constraints -> Data.state -> Data.term -> Data.state * 'a * extra_goals + constraint 'c = #ctx - type 'a t = { + type ('a,'c) t = { ty : ty_ast; pp_doc : Format.formatter -> unit -> unit; pp : Format.formatter -> 'a -> unit; - embed : 'a embedding; (* 'a -> term *) - readback : 'a readback; (* term -> 'a *) + embed : ('a,'c) embedding; (* 'a -> term *) + readback : ('a,'c) readback; (* term -> 'a *) } + constraint 'c = #ctx - exception TypeErr of ty_ast * int (*depth*) * Data.term (* a type error at data conversion time *) -end - -(** This module defines what embedding and readback functions are - for datatypes that need the context of the program (hypothetical clauses and - constraints) *) -module ContextualConversion : sig + val (^^) : ('a, ctx) t -> ('a, 'c) t - type ty_ast = Conversion.ty_ast = TyName of string | TyApp of string * ty_ast * ty_ast list + type 'a ctx_entry = { entry : 'a; depth : int } + val pp_ctx_entry : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a ctx_entry -> unit + val show_ctx_entry : (Format.formatter -> 'a -> unit) -> 'a ctx_entry -> string + type 'a ctx_field = 'a ctx_entry Data.Constants.Map.t - type ('a,'hyps,'constraints) embedding = - depth:int -> 'hyps -> 'constraints -> - Data.state -> 'a -> Data.state * Data.term * Conversion.extra_goals - - type ('a,'hyps,'constraints) readback = - depth:int -> 'hyps -> 'constraints -> - Data.state -> Data.term -> Data.state * 'a * Conversion.extra_goals - - type ('a,'h,'c) t = { - ty : ty_ast; - pp_doc : Format.formatter -> unit -> unit; - pp : Format.formatter -> 'a -> unit; - embed : ('a,'h,'c) embedding; (* 'a -> term *) - readback : ('a,'h,'c) readback; (* term -> 'a *) + (* A context that can be read on top of context 'c, made of items 'a indexed by 'k *) + type ('a,'k,'c) context = { + is_entry_for_nominal : Data.hyp -> Data.constant option; + to_key : depth:int -> 'a -> 'k; + push : depth:int -> Data.state -> 'k -> 'a ctx_entry -> Data.state; + pop : depth:int -> Data.state -> 'k -> Data.state; + conv : (Data.constant * 'a, #ctx as 'c) t; + init : Data.state -> Data.state; + get : Data.state -> 'a ctx_field } + type 'c ctx_readback = + depth:int -> Data.hyps -> Data.constraints -> Data.state -> Data.state * 'c * extra_goals + constraint 'c = #ctx - type ('hyps,'constraints) ctx_readback = - depth:int -> Data.hyps -> Data.constraints -> - Data.state -> Data.state * 'hyps * 'constraints * Conversion.extra_goals - - val unit_ctx : (unit,unit) ctx_readback - val raw_ctx : (Data.hyps,Data.constraints) ctx_readback - - (* cast *) - val (!<) : ('a,unit,unit) t -> 'a Conversion.t - - (* morphisms *) - val (!>) : 'a Conversion.t -> ('a,'hyps,'constraints) t - val (!>>) : ('a Conversion.t -> 'b Conversion.t) -> ('a,'hyps,'constraints) t -> ('b,'hyps,'constraints) t - val (!>>>) : ('a Conversion.t -> 'b Conversion.t -> 'c Conversion.t) -> ('a,'hyps,'constraints) t -> ('b,'hyps,'constraints) t -> ('c,'hyps,'constraints) t + type dummy + val in_raw_ctx : ctx ctx_readback + val in_raw : (dummy, dummy, #ctx as 'a) context end -(** Conversion for Elpi's built-in data types *) -module BuiltInData : sig - - (** See Elpi_builtin for a few more *) - val int : int Conversion.t - val float : float Conversion.t - val string : string Conversion.t - val list : 'a Conversion.t -> 'a list Conversion.t - val loc : Ast.Loc.t Conversion.t - - (* poly "A" is what one would use for, say, [type eq A -> A -> prop] *) - val poly : string -> Data.term Conversion.t - - (* like poly "A" but "A" must be a closed term, e.g. no unification variables - and no variables bound by the program (context) *) - val closed : string -> (Data.term * int) Conversion.t - - (* any is like poly "X" for X fresh *) - val any : Data.term Conversion.t - -end - (** Declare data from the host application that is opaque (no syntax), like int but not like list or pair *) module OpaqueData : sig @@ -332,6 +316,7 @@ module OpaqueData : sig *) type 'a declaration = { name : name; + cname : name; doc : doc; pp : Format.formatter -> 'a -> unit; compare : 'a -> 'a -> int; @@ -340,7 +325,28 @@ module OpaqueData : sig constants : (name * 'a) list; (* global constants of that type, eg "std_in" *) } - val declare : 'a declaration -> 'a Conversion.t + type 'a cdata_with_constants + + val declare : 'a declaration -> + Conversion.ty_ast * (Format.formatter -> 'a -> unit) * (Format.formatter -> unit -> unit) * 'a cdata_with_constants + + (** To circumvent value restriction you have assemble a Conversion.t by + hand. Example (top level of a module): + + let ty, pp, pp_doc, name = declare { + name = "name"; + cname = "Names.Name.t"; + doc = "Name hints"; + pp = ... + } + let name : 'c. (Names.Name.t, #ctx as 'c) t= { ty; pp; pp_doc; + embed = (fun ~depth -> embed name ~depth); + readback = (fun ~depth -> readback name ~depth); + } + + *) + val embed : 'a cdata_with_constants -> ('a,'c) Conversion.embedding + val readback : 'a cdata_with_constants -> ('a,'c) Conversion.readback end @@ -400,34 +406,43 @@ module AlgebraicData : sig - S stands for self - C stands for container *) - type ('stateful_builder,'builder, 'stateful_matcher, 'matcher, 'self, 'hyps,'constraints) constructor_arguments = + type ('stateful_builder,'builder, 'stateful_matcher, 'matcher, 'self, 'c) constructor_arguments = (* No arguments *) - | N : (Data.state -> Data.state * 'self, 'self, Data.state -> Data.state * Data.term * Conversion.extra_goals, Data.term, 'self, 'hyps,'constraints) constructor_arguments - (* An argument of type 'a *) - | A : 'a Conversion.t * ('bs,'b, 'ms,'m, 'self, 'hyps,'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps,'constraints) constructor_arguments - (* An argument of type 'a in context 'hyps,'constraints *) - | CA : ('a,'hyps,'constraints) ContextualConversion.t * ('bs,'b, 'ms,'m, 'self, 'hyps,'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps,'constraints) constructor_arguments + | N : (Data.state -> Data.state * 'self, 'self, Data.state -> Data.state * Data.term * Conversion.extra_goals, Data.term, 'self, 'c) constructor_arguments + (* An argument of type 'a in context 'c *) + | A : ('a,'c) Conversion.t * ('bs,'b, 'ms,'m, 'self, 'c) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'c) constructor_arguments (* An argument of type 'self *) - | S : ('bs,'b, 'ms, 'm, 'self, 'hyps,'constraints) constructor_arguments -> ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, 'hyps,'constraints) constructor_arguments + | S : ('bs,'b, 'ms, 'm, 'self, 'c) constructor_arguments -> ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, 'c) constructor_arguments (* An argument of type `T 'self` for a constainer `T`, like a `list 'self`. `S args` above is a shortcut for `C(fun x -> x, args)` *) - | C : (('self,'hyps,'constraints) ContextualConversion.t -> ('a,'hyps,'constraints) ContextualConversion.t) * ('bs,'b,'ms,'m,'self, 'hyps,'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms,'a -> 'm, 'self, 'hyps,'constraints) constructor_arguments + | C : (('self,Conversion.ctx) Conversion.t -> ('a,Conversion.ctx) Conversion.t) * ('bs,'b,'ms,'m,'self, 'c) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms,'a -> 'm, 'self, 'c) constructor_arguments - type ('t,'h,'c) constructor = + type ('t,'c) constructor = K : name * doc * - ('build_stateful_t,'build_t,'match_stateful_t,'match_t,'t,'h,'c) constructor_arguments * (* args ty *) + ('build_stateful_t,'build_t,'match_stateful_t,'match_t,'t,'c) constructor_arguments * (* args ty *) ('build_stateful_t,'build_t) build_t * ('match_stateful_t,'match_t,'t) match_t - -> ('t,'h,'c) constructor + -> ('t,'c) constructor - type ('t,'h,'c) declaration = { + type ('t,'c) declaration = { ty : Conversion.ty_ast; doc : doc; pp : Format.formatter -> 't -> unit; - constructors : ('t,'h,'c) constructor list; + constructors : ('t,'c) constructor list; } + constraint 'c = #Conversion.ctx + + (** In order to obtain a quantification over the context one can do + as follows: + + let { ty; pp; pp_doc; embed; readback } = declare { ... } + let foo : 'c. (foo, #ctx as 'c) t = { ty; pp; pp_doc; + embed = (fun ~depth (c : #ctx) -> embed ~depth (c :> ctx)); + readback = (fun ~depth (c : #ctx) -> readback ~depth (c :> ctx)); + } - val declare : ('t,'h,'c) declaration -> ('t,'h,'c) ContextualConversion.t + *) + val declare : ('t,Conversion.ctx) declaration -> ('t,Conversion.ctx) Conversion.t end @@ -501,29 +516,23 @@ module BuiltInPredicate : sig type 'a oarg = Keep | Discard type 'a ioarg = private Data of 'a | NoData - type ('function_type, 'inernal_outtype_in, 'internal_hyps, 'internal_constraints) ffi = - (* Arguemnts that are translated independently of the program context *) - | In : 't Conversion.t * doc * ('i, 'o,'h,'c) ffi -> ('t -> 'i,'o,'h,'c) ffi - | Out : 't Conversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t oarg -> 'i,'o,'h,'c) ffi - | InOut : 't ioarg Conversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t ioarg -> 'i,'o,'h,'c) ffi - - (* Arguemnts that are translated looking at the program context *) - | CIn : ('t,'h,'c) ContextualConversion.t * doc * ('i, 'o,'h,'c) ffi -> ('t -> 'i,'o,'h,'c) ffi - | COut : ('t,'h,'c) ContextualConversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t oarg -> 'i,'o,'h,'c) ffi - | CInOut : ('t ioarg,'h,'c) ContextualConversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t ioarg -> 'i,'o,'h,'c) ffi + type ('function_type, 'inernal_outtype_in, 'internal_hyps) ffi = + | In : ('t,'h) Conversion.t * doc * ('i, 'o,'h) ffi -> ('t -> 'i,'o,'h) ffi + | Out : ('t,'h) Conversion.t * doc * ('i, 'o * 't option,'h) ffi -> ('t oarg -> 'i,'o,'h) ffi + | InOut : ('t ioarg,'h) Conversion.t * doc * ('i, 'o * 't option,'h) ffi -> ('t ioarg -> 'i,'o,'h) ffi (* The easy case: all arguments are context independent *) - | Easy : doc -> (depth:int -> 'o, 'o, unit, unit) ffi + | Easy : doc -> (depth:int -> 'o, 'o, 'h) ffi (* The advanced case: arguments are context dependent, here we provide the context readback function *) - | Read : ('h,'c) ContextualConversion.ctx_readback * doc -> (depth:int -> 'h -> 'c -> Data.state -> 'o, 'o,'h,'c) ffi - | Full : ('h,'c) ContextualConversion.ctx_readback * doc -> (depth:int -> 'h -> 'c -> Data.state -> Data.state * 'o * Conversion.extra_goals, 'o,'h,'c) ffi - | VariadicIn : ('h,'c) ContextualConversion.ctx_readback * ('t,'h,'c) ContextualConversion.t * doc -> ('t list -> depth:int -> 'h -> 'c -> Data.state -> Data.state * 'o, 'o,'h,'c) ffi - | VariadicOut : ('h,'c) ContextualConversion.ctx_readback * ('t,'h,'c) ContextualConversion.t * doc -> ('t oarg list -> depth:int -> 'h -> 'c -> Data.state -> Data.state * ('o * 't option list option), 'o,'h,'c) ffi - | VariadicInOut : ('h,'c) ContextualConversion.ctx_readback * ('t ioarg,'h,'c) ContextualConversion.t * doc -> ('t ioarg list -> depth:int -> 'h -> 'c -> Data.state -> Data.state * ('o * 't option list option), 'o,'h,'c) ffi + | Read : doc -> (depth:int -> 'h -> Data.constraints -> Data.state -> 'o, 'o,'h) ffi + | Full : doc -> (depth:int -> 'h -> Data.constraints -> Data.state -> Data.state * 'o * Conversion.extra_goals, 'o,'h) ffi + | VariadicIn : ('t,'h) Conversion.t * doc -> ('t list -> depth:int -> 'h -> Data.constraints -> Data.state -> Data.state * 'o, 'o,'h) ffi + | VariadicOut : ('t,'h) Conversion.t * doc -> ('t oarg list -> depth:int -> 'h -> Data.constraints -> Data.state -> Data.state * ('o * 't option list option), 'o,'h) ffi + | VariadicInOut : ('t ioarg,'h) Conversion.t * doc -> ('t ioarg list -> depth:int -> 'h -> Data.constraints -> Data.state -> Data.state * ('o * 't option list option), 'o,'h) ffi - type t = Pred : name * ('a,unit,'h,'c) ffi * 'a -> t + type t = Pred : name * ('a,unit,'h) ffi * 'h Conversion.ctx_readback * 'a -> t (** Tools for InOut arguments. * @@ -555,9 +564,8 @@ module BuiltInPredicate : sig * would fail to unify with ok anyway) or the second one by not assigning TY. *) val mkData : 'a -> 'a ioarg - val ioargC : ('t,'h,'c) ContextualConversion.t -> ('t ioarg,'h,'c) ContextualConversion.t - val ioarg : 't Conversion.t -> 't ioarg Conversion.t - val ioarg_any : Data.term ioarg Conversion.t + val ioarg : ('t,'c) Conversion.t -> ('t ioarg,'c) Conversion.t + val ioarg_any : (Data.term ioarg,'c) Conversion.t module Notation : sig @@ -605,8 +613,7 @@ module BuiltIn : sig (* Real OCaml code *) | MLCode of BuiltInPredicate.t * doc_spec (* Declaration of an OCaml data *) - | MLData : 'a Conversion.t -> declaration - | MLDataC : ('a,'h,'c) ContextualConversion.t -> declaration + | MLData : ('a,'c) Conversion.t -> declaration (* Extra doc *) | LPDoc of string (* Sometimes you wrap OCaml code in regular predicates in order @@ -653,12 +660,20 @@ end module Query : sig type name = string - type _ arguments = - | N : unit arguments - | D : 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q : 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments - - type 'x t = Query of { predicate : name; arguments : 'x arguments } + type (_,_) arguments = + | N : (unit, 'c) arguments + | D : ('a, #Conversion.ctx as 'c) Conversion.t * 'a * ('x, 'c) arguments -> ('x, 'c) arguments + | Q : ('a, #Conversion.ctx as 'c) Conversion.t * name * ('x, 'c) arguments -> ('a * 'x, 'c) arguments + + type 'c obj_builder = Data.state -> 'c + constraint 'c = #Conversion.ctx + + type _ t = Query : ('a,'x,'c) query_contents * ('a,'k,Conversion.ctx) Conversion.context * 'c obj_builder -> 'x t + and ('a,'x,'c) query_contents = { + context : 'a list; + predicate : string; + arguments : ('x,'c) arguments; + } val compile : Compile.program -> Ast.Loc.t -> 'a t -> 'a Compile.query @@ -790,29 +805,137 @@ module FlexibleData : sig *) - val uvar : (Elpi.t * Data.term list) Conversion.t + val uvar : (Elpi.t * Data.term list, 'c) Conversion.t +end + +(** Conversion for Elpi's built-in data types *) +module BuiltInData : sig + + (** See Elpi_builtin for a few more *) + val int : (int, 'c) Conversion.t + val float : (float, 'c) Conversion.t + val string : (string, 'c) Conversion.t + val list : ('a, 'c) Conversion.t -> ('a list, 'c) Conversion.t + val loc : (Ast.Loc.t, 'c) Conversion.t + val bool : (bool, 'c) Conversion.t + val char : (char, 'c) Conversion.t + (* The string is the "file name" *) + val in_stream : (in_channel * string, 'c) Conversion.t + val out_stream : (out_channel * string, 'c) Conversion.t + + type diagnostic = private OK | ERROR of string BuiltInPredicate.ioarg + val diagnostic : (diagnostic, 'c) Conversion.t + val mkOK : diagnostic + val mkERROR : string -> diagnostic + + (* poly "A" is what one would use for, say, [type eq A -> A -> prop] *) + val poly : string -> (Data.term, 'c) Conversion.t + + (* like poly "A" but "A" must be a closed term, e.g. no unification variables + and no variables bound by the program (context) *) + val closed : string -> (Data.term * int, 'c) Conversion.t + + (* any is like poly "X" for X fresh *) + val any : (Data.term, 'c) Conversion.t + + val nominal : (Data.constant, 'c) Conversion.t + +end + +module Utils : sig + + (** A regular error (fatal) *) + val error : ?loc:Ast.Loc.t ->string -> 'a + + (** An invariant is broken, i.e. a bug *) + val anomaly : ?loc:Ast.Loc.t ->string -> 'a + + (** A type error (in principle ruled out by [elpi-checker.elpi]) *) + val type_error : ?loc:Ast.Loc.t ->string -> 'a + + (** A non fatal warning *) + val warn : ?loc:Ast.Loc.t ->string -> unit + + (** alias for printf and eprintf that write on the formatters set in Setup *) + val printf : ('a, Format.formatter, unit) format -> 'a + val eprintf : ('a, Format.formatter, unit) format -> 'a + + (** link between OCaml and LP lists. Note that [1,2|X] is not a valid + * OCaml list! *) + val list_to_lp_list : Data.term list -> Data.term + val lp_list_to_list : depth:int -> Data.term -> Data.term list + + (** The body of an assignment, if any (LOW LEVEL). + * Use [look] and forget about this API since the term you get + * needs to be moved and/or reduced, and you have no API for this. *) + val get_assignment : FlexibleData.Elpi.t -> Data.term option + + (** Hackish, in particular the output should be a compiled program *) + val clause_of_term : + ?name:string -> ?graft:([`After | `Before] * string) -> + depth:int -> Ast.Loc.t -> Data.term -> Ast.program + + (** Lifting/restriction/beta (LOW LEVEL, don't use) *) + val move : from:int -> to_:int -> Data.term -> Data.term + val beta : depth:int -> Data.term -> Data.term list -> Data.term + + (** readback/embed on lists *) + val map_acc : + (Data.state -> 't -> Data.state * 'a * Conversion.extra_goals) -> + Data.state -> 't list -> Data.state * 'a list * Conversion.extra_goals + + module type Show = sig + type t + val pp : Format.formatter -> t -> unit + val show : t -> string + end + + module type Show1 = sig + type 'a t + val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + val show : (Format.formatter -> 'a -> unit) -> 'a t -> string + end + + module Map : sig + module type S = sig + include Map.S + include Show1 with type 'a t := 'a t + end + + module type OrderedType = sig + include Map.OrderedType + include Show with type t := t + end + + module Make (Ord : OrderedType) : S with type key = Ord.t + + end + + module Set : sig + + module type S = sig + include Set.S + include Show with type t := t + end + + module type OrderedType = sig + include Set.OrderedType + include Show with type t := t + end + + module Make (Ord : OrderedType) : S with type elt = Ord.t + + end + end (** Low level module for OpaqueData *) module RawOpaqueData : sig - type name = string - type doc = string - type t (** If the data_hconsed is true, then the [cin] function below will automatically hashcons the data using the [eq] and [hash] functions. *) - type 'a declaration = 'a OpaqueData.declaration = { - name : name; - doc : doc; - pp : Format.formatter -> 'a -> unit; - compare : 'a -> 'a -> int; - hash : 'a -> int; - hconsed : bool; - constants : (name * 'a) list; (* global constants of that type, eg "std_in" *) - } - type 'a cdata = private { cin : 'a -> t; isc : t -> bool; @@ -820,7 +943,7 @@ module RawOpaqueData : sig name : string; } - val declare : 'a declaration -> 'a cdata * 'a Conversion.t + val cdata : 'a OpaqueData.cdata_with_constants -> 'a cdata val pp : Format.formatter -> t -> unit val show : t -> string @@ -857,6 +980,11 @@ module RawOpaqueData : sig val to_loc : t -> Ast.Loc.t val of_loc : Ast.Loc.t -> Data.term + val char : char cdata + val is_char : t -> bool + val to_char : t -> char + val of_char : char -> Data.term + end (** This module exposes the low level representation of terms. @@ -866,7 +994,7 @@ end * substitutes assigned unification variables by their value. *) module RawData : sig - type constant = int (** De Bruijn levels (not indexes): + type constant = Data.constant (** De Bruijn levels (not indexes): the distance of the binder from the root. Starts at 0 and grows for bound variables; global constants have negative values. *) @@ -901,7 +1029,7 @@ module RawData : sig val mkNil : term val mkDiscard : term val mkCData : RawOpaqueData.t -> term - val mkUnifVar : FlexibleData.Elpi.t -> args:term list -> State.t -> term + val mkUnifVar : FlexibleData.Elpi.t -> args:term list -> Data.state -> term (** Lower level smart constructors *) val mkGlobal : constant -> term (* global constant, i.e. < 0 *) @@ -911,15 +1039,9 @@ module RawData : sig val mkConst : constant -> term (* no check, works for globals and bound *) val cmp_builtin : builtin -> builtin -> int - type hyp = { - hdepth : int; - hsrc : term - } - type hyps = hyp list - val of_hyps : Data.hyp list -> hyps type suspended_goal = { - context : hyps; + context : Data.hyps; goal : int * term } val constraints : Data.constraints -> suspended_goal list @@ -948,8 +1070,8 @@ module RawData : sig (* Marker for spilling function calls, as in [{ rev L }] *) val spillc : constant - module Map : Map.S with type key = constant - module Set : Set.S with type elt = constant + module Map = Data.Constants.Map + module Set : Utils.Set.S with type elt = constant end @@ -962,39 +1084,42 @@ module RawQuery : sig to the eventual solution. The compiler transforms it, later on, into a UnifVar. Use the name to fetch the solution. *) val mk_Arg : - State.t -> name:string -> args:Data.term list -> - State.t * Data.term + Data.state -> name:string -> args:Data.term list -> + Data.state * Data.term (* Args are parameters of the query (e.g. capital letters). *) - val is_Arg : State.t -> Data.term -> bool + val is_Arg : Data.state -> Data.term -> bool + + type 'a query_readback = Data.term Data.StrMap.t -> Data.constraints -> State.t -> 'a val compile : - Compile.program -> (depth:int -> State.t -> State.t * (Ast.Loc.t * Data.term)) -> - unit Compile.query + Compile.program -> + (depth:int -> Data.hyps -> Data.constraints -> Data.state -> Data.state * (Ast.Loc.t * Data.term) * 'a query_readback) -> + 'a Compile.query end module Quotation : sig type quotation = - depth:int -> State.t -> Ast.Loc.t -> string -> State.t * Data.term + depth:int -> Data.state -> Ast.Loc.t -> string -> Data.state * Data.term (** The default quotation [{{code}}] *) val set_default_quotation : quotation -> unit - (** Named quotation [{{name:code}}] *) + (** Named quotation [{{:name code}}] *) val register_named_quotation : name:string -> quotation -> unit (** The anti-quotation to lambda Prolog *) val lp : quotation (** See elpi-quoted_syntax.elpi (EXPERIMENTAL, used by elpi-checker) *) - val quote_syntax_runtime : State.t -> 'a Compile.query -> State.t * Data.term list * Data.term - val quote_syntax_compiletime : State.t -> 'a Compile.query -> State.t * Data.term list * Data.term + val quote_syntax_runtime : Data.state -> 'a Compile.query -> Data.state * Data.term list * Data.term + val quote_syntax_compiletime : Data.state -> 'a Compile.query -> Data.state * Data.term list * Data.term (** To implement the string_to_term built-in (AVOID, makes little sense * if depth is non zero, since bound variables have no name!) *) - val term_at : depth:int -> State.t -> Ast.query -> State.t * Data.term + val term_at : depth:int -> Data.state -> Ast.query -> Data.state * Data.term (** Like quotations but for identifiers that begin and end with * "`" or "'", e.g. `this` and 'that'. Useful if the object language @@ -1002,93 +1127,10 @@ module Quotation : sig * (e.g. CD.string like but with a case insensitive comparison) *) val declare_backtick : name:string -> - (State.t -> string -> State.t * Data.term) -> unit + (Data.state -> string -> Data.state * Data.term) -> unit val declare_singlequote : name:string -> - (State.t -> string -> State.t * Data.term) -> unit - -end - -module Utils : sig - - (** A regular error (fatal) *) - val error : ?loc:Ast.Loc.t ->string -> 'a - - (** An invariant is broken, i.e. a bug *) - val anomaly : ?loc:Ast.Loc.t ->string -> 'a - - (** A type error (in principle ruled out by [elpi-checker.elpi]) *) - val type_error : ?loc:Ast.Loc.t ->string -> 'a - - (** A non fatal warning *) - val warn : ?loc:Ast.Loc.t ->string -> unit - - (** link between OCaml and LP lists. Note that [1,2|X] is not a valid - * OCaml list! *) - val list_to_lp_list : Data.term list -> Data.term - val lp_list_to_list : depth:int -> Data.term -> Data.term list - - (** The body of an assignment, if any (LOW LEVEL). - * Use [look] and forget about this API since the term you get - * needs to be moved and/or reduced, and you have no API for this. *) - val get_assignment : FlexibleData.Elpi.t -> Data.term option - - (** Hackish, in particular the output should be a compiled program *) - val clause_of_term : - ?name:string -> ?graft:([`After | `Before] * string) -> - depth:int -> Ast.Loc.t -> Data.term -> Ast.program - - (** Lifting/restriction/beta (LOW LEVEL, don't use) *) - val move : from:int -> to_:int -> Data.term -> Data.term - val beta : depth:int -> Data.term -> Data.term list -> Data.term - - (** readback/embed on lists *) - val map_acc : - (State.t -> 't -> State.t * 'a * Conversion.extra_goals) -> - State.t -> 't list -> State.t * 'a list * Conversion.extra_goals - - module type Show = sig - type t - val pp : Format.formatter -> t -> unit - val show : t -> string - end - - module type Show1 = sig - type 'a t - val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val show : (Format.formatter -> 'a -> unit) -> 'a t -> string - end - - module Map : sig - module type S = sig - include Map.S - include Show1 with type 'a t := 'a t - end - - module type OrderedType = sig - include Map.OrderedType - include Show with type t := t - end - - module Make (Ord : OrderedType) : S with type key = Ord.t - - end - - module Set : sig - - module type S = sig - include Set.S - include Show with type t := t - end - - module type OrderedType = sig - include Set.OrderedType - include Show with type t := t - end - - module Make (Ord : OrderedType) : S with type elt = Ord.t - - end + (Data.state -> string -> Data.state * Data.term) -> unit end @@ -1114,4 +1156,52 @@ module RawPp : sig end +module PPX : sig + (** Access to internal API to implement elpi.ppx *) + + val readback_int : (int, 'c) Conversion.readback + val readback_float : (float, 'c) Conversion.readback + val readback_string : (string, 'c) Conversion.readback + val readback_list : ('a, 'c) Conversion.readback -> ('a list,'c) Conversion.readback + val readback_loc : (Ast.Loc.t, 'c) Conversion.readback + val readback_nominal : (RawData.constant, 'c) Conversion.readback + + val embed_int : (int, 'c) Conversion.embedding + val embed_float : (float, 'c) Conversion.embedding + val embed_string : (string, 'c) Conversion.embedding + val embed_list : ('a, 'c) Conversion.embedding -> ('a list, 'c) Conversion.embedding + val embed_loc : (Ast.Loc.t, 'c) Conversion.embedding + val embed_nominal : (RawData.constant, 'c) Conversion.embedding + + type context_description = + | C : ('a,'k,'c) Conversion.context -> context_description + + val readback_context : + ('a,'k,'c) Conversion.context -> + 'c -> + depth:int -> + Data.hyps -> + Data.constraints -> + Data.state -> Data.state * Conversion.extra_goals + + module Doc : sig + + val kind : Format.formatter -> Conversion.ty_ast -> doc:string -> unit + val comment : Format.formatter -> string -> unit + val constructor : Format.formatter -> + name:string -> doc:string -> + ty:Conversion.ty_ast -> + args:Conversion.ty_ast list -> unit + val adt : + doc:string -> + ty:Conversion.ty_ast -> + args:(string * string * Conversion.ty_ast list) list -> + Format.formatter -> unit -> unit + val show_ty_ast : ?outer:bool -> Conversion.ty_ast -> string + end + +end + + + (**/**) diff --git a/src/builtin.elpi b/src/builtin.elpi index b401ae9d2..5e76d97db 100644 --- a/src/builtin.elpi +++ b/src/builtin.elpi @@ -218,6 +218,10 @@ kind bool type. type tt bool. type ff bool. +% an octect +typeabbrev char (ctype "char"). + + % Pair: the constructor is pr, since ',' is for conjunction kind pair type -> type -> type. type pr A -> B -> pair A B. @@ -230,6 +234,63 @@ pred snd i:pair A B, o:B. snd (pr _ B) B. +kind triple type -> type -> type -> type. +type triple A -> B -> C -> triple A B C. + +pred triple_1 i:triple A1 A2 A3, o:A1. + +triple_1 (triple X _ _) X. + +pred triple_2 i:triple A1 A2 A3, o:A2. + +triple_2 (triple _ X _) X. + +pred triple_3 i:triple A1 A2 A3, o:A3. + +triple_3 (triple _ _ X) X. + +kind quadruple type -> type -> type -> type -> type. +type quadruple A -> B -> C -> D -> quadruple A B C D. + +pred quadruple_1 i:quadruple A1 A2 A3 A4, o:A1. + +quadruple_1 (quadruple X _ _ _) X. + +pred quadruple_2 i:quadruple A1 A2 A3 A4, o:A2. + +quadruple_2 (quadruple _ X _ _) X. + +pred quadruple_3 i:quadruple A1 A2 A3 A4, o:A3. + +quadruple_3 (quadruple _ _ X _) X. + +pred quadruple_4 i:quadruple A1 A2 A3 A4, o:A4. + +quadruple_4 (quadruple _ _ _ X) X. + +kind quintuple type -> type -> type -> type -> type -> type. +type quintuple A -> B -> C -> D -> E -> quintuple A B C D E. + +pred quintuple_1 i:quintuple A1 A2 A3 A4 A5, o:A1. + +quintuple_1 (quintuple X _ _ _ _) X. + +pred quintuple_2 i:quintuple A1 A2 A3 A4 A5, o:A2. + +quintuple_2 (quintuple _ X _ _ _) X. + +pred quintuple_3 i:quintuple A1 A2 A3 A4 A5, o:A3. + +quintuple_3 (quintuple _ _ X _ _) X. + +pred quintuple_4 i:quintuple A1 A2 A3 A4 A5, o:A4. + +quintuple_4 (quintuple _ _ _ X _) X. + +pred quintuple_5 i:quintuple A1 A2 A3 A4 A5, o:A5. + +quintuple_5 (quintuple _ _ _ _ X) X. + % The option type (aka Maybe) kind option type -> type. type none option A. @@ -903,7 +964,7 @@ type std.map std.map.private.map K V -> (K -> K -> cmp -> prop) -> std.map K V. namespace std.map { -% [make Eq Ltn M] builds an empty map M where keys are compared using Eq and Ltn +% [make Cmp M] builds an empty map M where keys are compared using Cmp pred make i:(K -> K -> cmp -> prop), o:std.map K V. make Cmp (std.map private.empty Cmp). @@ -1010,7 +1071,7 @@ type std.set std.set.private.set E -> (E -> E -> cmp -> prop) -> std.set E. namespace std.set { -% [make Eq Ltn M] builds an empty set M where keys are compared using Eq and Ltn +% [make Cmp M] builds an empty set M where keys are compared using Cmp pred make i:(E -> E -> cmp -> prop), o:std.set E. make Cmp (std.set private.empty Cmp). diff --git a/src/builtin.ml b/src/builtin.ml index 5b1ae01c9..2a55ee152 100644 --- a/src/builtin.ml +++ b/src/builtin.ml @@ -10,26 +10,6 @@ open Notation module Str = Re.Str -let in_stream = OpaqueData.declare { - OpaqueData.name = "in_stream"; - pp = (fun fmt (_,d) -> Format.fprintf fmt "" d); - compare = (fun (_,s1) (_,s2) -> String.compare s1 s2); - hash = (fun (x,_) -> Hashtbl.hash x); - hconsed = false; - constants = ["std_in",(stdin,"stdin")]; - doc = ""; -} - -let out_stream = OpaqueData.declare { - OpaqueData.name = "out_stream"; - pp = (fun fmt (_,d) -> Format.fprintf fmt "" d); - compare = (fun (_,s1) (_,s2) -> String.compare s1 s2); - hash = (fun (x,_) -> Hashtbl.hash x); - hconsed = false; - doc = ""; - constants = ["std_out",(stdout,"stdout");"std_err",(stderr,"stderr")]; -} - let register_eval, register_eval_ty, lookup_eval, eval_declaration = let rec str_of_ty n s = if n = 0 then s else s ^ " -> " ^ str_of_ty (n-1) s in @@ -212,68 +192,140 @@ type polyop = { pname : string; } -let bool = AlgebraicData.declare { - AlgebraicData.ty = TyName "bool"; - doc = "Boolean values: tt and ff since true and false are predicates"; - pp = (fun fmt b -> Format.fprintf fmt "%b" b); - constructors = [ - K("tt","",N, - B true, - M (fun ~ok ~ko -> function true -> ok | _ -> ko ())); - K("ff","",N, - B false, - M (fun ~ok ~ko -> function false -> ok | _ -> ko ())); - ] -}|> ContextualConversion.(!<) +let typec = RawData.Constants.declare_global_symbol "pair" +let constructorc = RawData.Constants.declare_global_symbol "pr" +let tyast a b = Conversion.TyApp("pair",a,[b]) +let readback_pair readback_a1 readback_a2 ~depth hyps csts st x = + match RawData.look ~depth x with + | RawData.App(c,x1,[x2]) when c == constructorc -> + let st, x1, gls1 = readback_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = readback_a2 ~depth hyps csts st x2 in + st, (x1,x2), gls1 @ gls2 + | _ -> raise (Conversion.TypeErr(tyast (Conversion.TyName "A") (Conversion.TyName "B"),depth,x)) +let embed_pair embed_a1 embed_a2 ~depth hyps csts st x = + let (x1,x2) = x in + let st, x1, gls1 = embed_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = embed_a2 ~depth hyps csts st x2 in + st, RawData.mkApp constructorc x1 [x2], gls1 @ gls2 +let pair a1 a2 = let open Conversion in + let ty = tyast a1.ty a2.ty in { + ty; + pp_doc = (PPX.Doc.adt ~doc:"Pair: the constructor is pr, since ',' is for conjunction" ~ty ~args:["pr","",[a1.ty;a2.ty]]); + pp = (fun fmt (x1,x2) -> Format.fprintf fmt "(%a,%a)" a1.pp x1 a2.pp x2); + embed = embed_pair a1.embed a2.embed; + readback = readback_pair a1.readback a2.readback; +} -let pair a b = let open AlgebraicData in declare { - ty = TyApp ("pair",a.Conversion.ty,[b.Conversion.ty]); - doc = "Pair: the constructor is pr, since ',' is for conjunction"; - pp = (fun fmt o -> Format.fprintf fmt "%a" (Util.pp_pair a.Conversion.pp b.Conversion.pp) o); - constructors = [ - K("pr","",A(a,A(b,N)), - B (fun a b -> (a,b)), - M (fun ~ok ~ko:_ -> function (a,b) -> ok a b)); - ] -} |> ContextualConversion.(!<) +let typec = RawData.Constants.declare_global_symbol "triple" +let constructorc = RawData.Constants.declare_global_symbol "triple" +let tyast a b c = Conversion.TyApp("triple",a,[b;c]) +let readback_triple readback_a1 readback_a2 readback_a3 ~depth hyps csts st x = + match RawData.look ~depth x with + | RawData.App(c,x1,[x2;x3]) when c == constructorc -> + let st, x1, gls1 = readback_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = readback_a2 ~depth hyps csts st x2 in + let st, x3, gls3 = readback_a3 ~depth hyps csts st x3 in + st, (x1,x2,x3), gls1 @ gls2 @ gls3 + | _ -> raise (Conversion.TypeErr(tyast (Conversion.TyName "A") (Conversion.TyName "B") (Conversion.TyName "C"),depth,x)) +let embed_triple embed_a1 embed_a2 embed_a3 ~depth hyps csts st x = + let (x1,x2,x3) = x in + let st, x1, gls1 = embed_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = embed_a2 ~depth hyps csts st x2 in + let st, x3, gls3 = embed_a3 ~depth hyps csts st x3 in + st, RawData.mkApp constructorc x1 [x2;x3], gls1 @ gls2 @ gls3 +let triple a1 a2 a3 = let open Conversion in + let ty = tyast a1.ty a2.ty a3.ty in { + ty; + pp_doc = (PPX.Doc.adt ~doc:"" ~ty ~args:["triple","",[a1.ty;a2.ty;a3.ty]]); + pp = (fun fmt (x1,x2,x3) -> Format.fprintf fmt "(%a,%a,%a)" a1.pp x1 a2.pp x2 a3.pp x3); + embed = embed_triple a1.embed a2.embed a3.embed; + readback = readback_triple a1.readback a2.readback a3.readback; +} -let option a = let open AlgebraicData in declare { - ty = TyApp("option",a.Conversion.ty,[]); - doc = "The option type (aka Maybe)"; - pp = (fun fmt o -> Format.fprintf fmt "%a" (Util.pp_option a.Conversion.pp) o); - constructors = [ - K("none","",N, - B None, - M (fun ~ok ~ko -> function None -> ok | _ -> ko ())); - K("some","",A(a,N), - B (fun x -> Some x), - M (fun ~ok ~ko -> function Some x -> ok x | _ -> ko ())); - ] -} |> ContextualConversion.(!<) - -type diagnostic = OK | ERROR of string ioarg -let mkOK = OK -let mkERROR s = ERROR (mkData s) - -let diagnostic = let open API.AlgebraicData in declare { - ty = TyName "diagnostic"; - doc = "Used in builtin variants that return Coq's error rather than failing"; - pp = (fun fmt -> function - | OK -> Format.fprintf fmt "OK" - | ERROR NoData -> Format.fprintf fmt "ERROR _" - | ERROR (Data s) -> Format.fprintf fmt "ERROR %S" s); - constructors = [ - K("ok","Success",N, - B mkOK, - M (fun ~ok ~ko -> function OK -> ok | _ -> ko ())); - K("error","Failure",A(BuiltInPredicate.ioarg BuiltInData.string,N), - B (fun s -> ERROR s), - M (fun ~ok ~ko -> function ERROR s -> ok s | _ -> ko ())); - K("uvar","",A(FlexibleData.uvar,N), - B (fun _ -> assert false), - M (fun ~ok ~ko _ -> ko ())) - ] -} |> ContextualConversion.(!<) +let typec = RawData.Constants.declare_global_symbol "quadruple" +let constructorc = RawData.Constants.declare_global_symbol "quadruple" +let tyast a b c d = Conversion.TyApp("quadruple",a,[b;c;d]) +let readback_quadruple readback_a1 readback_a2 readback_a3 readback_a4 ~depth hyps csts st x = + match RawData.look ~depth x with + | RawData.App(c,x1,[x2;x3;x4]) when c == constructorc -> + let st, x1, gls1 = readback_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = readback_a2 ~depth hyps csts st x2 in + let st, x3, gls3 = readback_a3 ~depth hyps csts st x3 in + let st, x4, gls4 = readback_a4 ~depth hyps csts st x4 in + st, (x1,x2,x3,x4), gls1 @ gls2 @ gls3 @ gls4 + | _ -> raise (Conversion.TypeErr(tyast (Conversion.TyName "A") (Conversion.TyName "B") (Conversion.TyName "C") (Conversion.TyName "D"),depth,x)) +let embed_quadruple embed_a1 embed_a2 embed_a3 embed_a4 ~depth hyps csts st x = + let (x1,x2,x3,x4) = x in + let st, x1, gls1 = embed_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = embed_a2 ~depth hyps csts st x2 in + let st, x3, gls3 = embed_a3 ~depth hyps csts st x3 in + let st, x4, gls4 = embed_a4 ~depth hyps csts st x4 in + st, RawData.mkApp constructorc x1 [x2;x3;x4], gls1 @ gls2 @ gls3 @ gls4 +let quadruple a1 a2 a3 a4 = let open Conversion in + let ty = tyast a1.ty a2.ty a3.ty a4.ty in { + ty; + pp_doc = (PPX.Doc.adt ~doc:"" ~ty ~args:["quadruple","",[a1.ty;a2.ty;a3.ty;a4.ty]]); + pp = (fun fmt (x1,x2,x3,x4) -> Format.fprintf fmt "(%a,%a,%a,%a)" a1.pp x1 a2.pp x2 a3.pp x3 a4.pp x4); + embed = embed_quadruple a1.embed a2.embed a3.embed a4.embed; + readback = readback_quadruple a1.readback a2.readback a3.readback a4.readback; +} + +let typec = RawData.Constants.declare_global_symbol "quintuple" +let constructorc = RawData.Constants.declare_global_symbol "quintuple" +let tyast a b c d e = Conversion.TyApp("quintuple",a,[b;c;d;e]) +let readback_quintuple readback_a1 readback_a2 readback_a3 readback_a4 readback_a5 ~depth hyps csts st x = + match RawData.look ~depth x with + | RawData.App(c,x1,[x2;x3;x4;x5]) when c == constructorc -> + let st, x1, gls1 = readback_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = readback_a2 ~depth hyps csts st x2 in + let st, x3, gls3 = readback_a3 ~depth hyps csts st x3 in + let st, x4, gls4 = readback_a4 ~depth hyps csts st x4 in + let st, x5, gls5 = readback_a5 ~depth hyps csts st x5 in + st, (x1,x2,x3,x4,x5), gls1 @ gls2 @ gls3 @ gls4 @ gls5 + | _ -> raise (Conversion.TypeErr(tyast (Conversion.TyName "A") (Conversion.TyName "B") (Conversion.TyName "C") (Conversion.TyName "D") (Conversion.TyName "E"),depth,x)) +let embed_quintuple embed_a1 embed_a2 embed_a3 embed_a4 embed_a5 ~depth hyps csts st x = + let (x1,x2,x3,x4,x5) = x in + let st, x1, gls1 = embed_a1 ~depth hyps csts st x1 in + let st, x2, gls2 = embed_a2 ~depth hyps csts st x2 in + let st, x3, gls3 = embed_a3 ~depth hyps csts st x3 in + let st, x4, gls4 = embed_a4 ~depth hyps csts st x4 in + let st, x5, gls5 = embed_a5 ~depth hyps csts st x5 in + st, RawData.mkApp constructorc x1 [x2;x3;x4;x5], gls1 @ gls2 @ gls3 @ gls4 @ gls5 +let quintuple a1 a2 a3 a4 a5 = let open Conversion in + let ty = tyast a1.ty a2.ty a3.ty a4.ty a5.ty in { + ty; + pp_doc = (PPX.Doc.adt ~doc:"" ~ty ~args:["quintuple","",[a1.ty;a2.ty;a3.ty;a4.ty;a5.ty]]); + pp = (fun fmt (x1,x2,x3,x4,x5) -> Format.fprintf fmt "(%a,%a,%a,%a,%a)" a1.pp x1 a2.pp x2 a3.pp x3 a4.pp x4 a5.pp x5); + embed = embed_quintuple a1.embed a2.embed a3.embed a4.embed a5.embed; + readback = readback_quintuple a1.readback a2.readback a3.readback a4.readback a5.readback; +} + +let typec = RawData.Constants.declare_global_symbol "option" +let constructor1c = RawData.Constants.declare_global_symbol "none" +let constructor2c = RawData.Constants.declare_global_symbol "some" +let tyast a = Conversion.TyApp("option",a,[]) +let readback_option readback_a1 ~depth hyps csts st x = + match RawData.look ~depth x with + | RawData.App(c,x1,[]) when c == constructor2c -> + let st, x1, gls1 = readback_a1 ~depth hyps csts st x1 in + st, Some x1, gls1 + | RawData.Const c when c == constructor1c -> + st, None, [] + | _ -> raise (Conversion.TypeErr(tyast (Conversion.TyName "A"),depth,x)) +let embed_option embed_a1 ~depth hyps csts st x = + match x with + | None -> st, RawData.mkConst constructor1c, [] + | Some x1 -> + let st, x1, gls1 = embed_a1 ~depth hyps csts st x1 in + st, RawData.mkApp constructor2c x1 [], gls1 +let option a1 = let open Conversion in + let ty = tyast a1.ty in { + ty; + pp_doc = (PPX.Doc.adt ~doc:"The option type (aka Maybe)" ~ty ~args:["none","",[];"some","",[a1.ty]]); + pp = (fun fmt -> function None -> Format.fprintf fmt "None" | Some x1 -> Format.fprintf fmt "(Some %a)" a1.pp x1); + embed = embed_option a1.embed; + readback = readback_option a1.readback; +} let cmp = let open AlgebraicData in declare { ty = TyName "cmp"; @@ -284,7 +336,7 @@ let cmp = let open AlgebraicData in declare { K("lt", "", N, B ~-1, M(fun ~ok ~ko i -> if i < 0 then ok else ko ())); K("gt", "", N, B 1, M(fun ~ok ~ko i -> if i > 0 then ok else ko ())) ] -} |> ContextualConversion.(!<) +} let error_cmp_flex ~depth t1 t2 = error "cmp_term on non-ground terms" @@ -355,7 +407,7 @@ let rec check_ground ~depth t = (** Core built-in ********************************************************* *) -let core_builtins = let open BuiltIn in let open ContextualConversion in [ +let core_builtins = let open BuiltIn in let open Conversion in [ LPDoc " == Core builtins ====================================="; @@ -402,7 +454,7 @@ let core_builtins = let open BuiltIn in let open ContextualConversion in [ "external pred declare_constraint i:any, i:list any."); LPCode "external pred print_constraints. % prints all constraints"; - MLCode(Pred("halt", VariadicIn(unit_ctx, !> BuiltInData.any, "halts the program and print the terms"), + MLCode(Pred("halt", VariadicIn(BuiltInData.any, "halts the program and print the terms"),in_raw_ctx, (fun args ~depth _ _ -> if args = [] then error "halt" else @@ -420,7 +472,7 @@ let core_builtins = let open BuiltIn in let open ContextualConversion in [ MLCode(Pred("calc", In(BuiltInData.poly "A", "Expr", Out(BuiltInData.poly "A", "Out", - Easy "unifies Out with the value of Expr. It can be used in tandem with spilling, eg [f {calc (N + 1)}]")), + Easy "unifies Out with the value of Expr. It can be used in tandem with spilling, eg [f {calc (N + 1)}]")),in_raw_ctx, (fun t _ ~depth -> !:(eval depth t))), DocAbove); @@ -436,7 +488,7 @@ let core_builtins = let open BuiltIn in let open ContextualConversion in [ MLCode(Pred(pname, In(BuiltInData.poly "A","X", In(BuiltInData.poly "A","Y", - Easy ("checks if X " ^ psym ^ " Y. Works for string, int and float"))), + Easy ("checks if X " ^ psym ^ " Y. Works for string, int and float"))),in_raw_ctx, (fun t1 t2 ~depth -> let open RawOpaqueData in let t1 = look ~depth (eval depth t1) in @@ -495,7 +547,8 @@ let core_builtins = let open BuiltIn in let open ContextualConversion in [ LPCode "type (::) X -> list X -> list X."; LPCode "type ([]) list X."; - MLData bool; + MLData BuiltInData.bool; + MLData BuiltInData.char; MLData (pair (BuiltInData.poly "A") (BuiltInData.poly "B")); @@ -504,18 +557,51 @@ let core_builtins = let open BuiltIn in let open ContextualConversion in [ LPCode "pred snd i:pair A B, o:B."; LPCode "snd (pr _ B) B."; + MLData (triple (BuiltInData.poly "A") (BuiltInData.poly "B") (BuiltInData.poly "C")); + + LPCode "pred triple_1 i:triple A1 A2 A3, o:A1."; + LPCode "triple_1 (triple X _ _) X."; + LPCode "pred triple_2 i:triple A1 A2 A3, o:A2."; + LPCode "triple_2 (triple _ X _) X."; + LPCode "pred triple_3 i:triple A1 A2 A3, o:A3."; + LPCode "triple_3 (triple _ _ X) X."; + + MLData (quadruple (BuiltInData.poly "A") (BuiltInData.poly "B") (BuiltInData.poly "C") (BuiltInData.poly "D")); + + LPCode "pred quadruple_1 i:quadruple A1 A2 A3 A4, o:A1."; + LPCode "quadruple_1 (quadruple X _ _ _) X."; + LPCode "pred quadruple_2 i:quadruple A1 A2 A3 A4, o:A2."; + LPCode "quadruple_2 (quadruple _ X _ _) X."; + LPCode "pred quadruple_3 i:quadruple A1 A2 A3 A4, o:A3."; + LPCode "quadruple_3 (quadruple _ _ X _) X."; + LPCode "pred quadruple_4 i:quadruple A1 A2 A3 A4, o:A4."; + LPCode "quadruple_4 (quadruple _ _ _ X) X."; + + MLData (quintuple (BuiltInData.poly "A") (BuiltInData.poly "B") (BuiltInData.poly "C") (BuiltInData.poly "D") (BuiltInData.poly "E")); + + LPCode "pred quintuple_1 i:quintuple A1 A2 A3 A4 A5, o:A1."; + LPCode "quintuple_1 (quintuple X _ _ _ _) X."; + LPCode "pred quintuple_2 i:quintuple A1 A2 A3 A4 A5, o:A2."; + LPCode "quintuple_2 (quintuple _ X _ _ _) X."; + LPCode "pred quintuple_3 i:quintuple A1 A2 A3 A4 A5, o:A3."; + LPCode "quintuple_3 (quintuple _ _ X _ _) X."; + LPCode "pred quintuple_4 i:quintuple A1 A2 A3 A4 A5, o:A4."; + LPCode "quintuple_4 (quintuple _ _ _ X _) X."; + LPCode "pred quintuple_5 i:quintuple A1 A2 A3 A4 A5, o:A5."; + LPCode "quintuple_5 (quintuple _ _ _ _ X) X."; + MLData (option (BuiltInData.poly "A")); MLData cmp; - MLData diagnostic; + MLData BuiltInData.diagnostic; ] ;; (** Standard lambda Prolog I/O built-in *********************************** *) -let io_builtins = let open BuiltIn in let open BuiltInData in [ +let io_builtins = let open BuiltIn in let open BuiltInData in let open Conversion in [ LPDoc " == I/O builtins ====================================="; @@ -524,11 +610,11 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLData (in_stream); MLData (out_stream); - + MLCode(Pred("open_in", In(string, "FileName", Out(in_stream, "InStream", - Easy "opens FileName for input")), + Easy "opens FileName for input")),in_raw_ctx, (fun s _ ~depth -> try !:(open_in s,s) with Sys_error msg -> error msg)), @@ -537,7 +623,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("open_out", In(string, "FileName", Out(out_stream, "OutStream", - Easy "opens FileName for output")), + Easy "opens FileName for output")),in_raw_ctx, (fun s _ ~depth -> try !:(open_out s,s) with Sys_error msg -> error msg)), @@ -546,7 +632,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("open_append", In(string, "FileName", Out(out_stream, "OutStream", - Easy "opens FileName for output in append mode")), + Easy "opens FileName for output in append mode")),in_raw_ctx, (fun s _ ~depth -> let flags = [Open_wronly; Open_append; Open_creat; Open_text] in try !:(open_out_gen flags 0x664 s,s) @@ -555,7 +641,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("close_in", In(in_stream, "InStream", - Easy "closes input stream InStream"), + Easy "closes input stream InStream"),in_raw_ctx, (fun (i,_) ~depth -> try close_in i with Sys_error msg -> error msg)), @@ -563,7 +649,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("close_out", In(out_stream, "OutStream", - Easy "closes output stream OutStream"), + Easy "closes output stream OutStream"),in_raw_ctx, (fun (o,_) ~depth -> try close_out o with Sys_error msg -> error msg)), @@ -572,7 +658,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("output", In(out_stream, "OutStream", In(string, "Data", - Easy "writes Data to OutStream")), + Easy "writes Data to OutStream")),in_raw_ctx, (fun (o,_) s ~depth -> try output_string o s with Sys_error msg -> error msg)), @@ -580,7 +666,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("flush", In(out_stream, "OutStream", - Easy "flush all output not yet finalized to OutStream"), + Easy "flush all output not yet finalized to OutStream"),in_raw_ctx, (fun (o,_) ~depth -> try flush o with Sys_error msg -> error msg)), @@ -590,7 +676,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ In(in_stream, "InStream", In(int, "Bytes", Out(string, "Data", - Easy "reads Bytes from InStream"))), + Easy "reads Bytes from InStream"))),in_raw_ctx, (fun (i,_) n _ ~depth -> let buf = Bytes.make n ' ' in try @@ -603,7 +689,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("input_line", In(in_stream, "InStream", Out(string, "Line", - Easy "reads a full line from InStream")), + Easy "reads a full line from InStream")),in_raw_ctx, (fun (i,_) _ ~depth -> try !:(input_line i) with @@ -613,7 +699,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("eof", In(in_stream, "InStream", - Easy "checks if no more data can be read from InStream"), + Easy "checks if no more data can be read from InStream"),in_raw_ctx, (fun (i,_) ~depth -> try let pos = pos_in i in @@ -629,14 +715,14 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("gettimeofday", Out(float, "T", - Easy "sets T to the number of seconds elapsed since 1/1/1970"), + Easy "sets T to the number of seconds elapsed since 1/1/1970"),in_raw_ctx, (fun _ ~depth -> !:(Unix.gettimeofday ()))), DocAbove); MLCode(Pred("getenv", In(string, "VarName", Out(option string, "Value", - Easy ("Like Sys.getenv"))), + Easy ("Like Sys.getenv"))),in_raw_ctx, (fun s _ ~depth -> try !:(Some (Sys.getenv s)) with Not_found -> !: None)), @@ -645,7 +731,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("system", In(string, "Command", Out(int, "RetVal", - Easy "executes Command and sets RetVal to the exit code")), + Easy "executes Command and sets RetVal to the exit code")),in_raw_ctx, (fun s _ ~depth -> !:(Sys.command s))), DocAbove); @@ -654,7 +740,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("term_to_string", In(any, "T", Out(string, "S", - Easy "prints T to S")), + Easy "prints T to S")),in_raw_ctx, (fun t _ ~depth -> let b = Buffer.create 1024 in let fmt = Format.formatter_of_buffer b in @@ -668,7 +754,7 @@ let io_builtins = let open BuiltIn in let open BuiltInData in [ (** Standard lambda Prolog built-in ************************************** *) -let lp_builtins = let open BuiltIn in let open BuiltInData in [ +let lp_builtins = let open BuiltIn in let open BuiltInData in let open Conversion in [ LPDoc "== Lambda Prolog builtins ====================================="; @@ -677,7 +763,7 @@ let lp_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("open_string", In(string, "DataIn", Out(in_stream, "InStream", - Easy "opens DataIn as an input stream")), + Easy "opens DataIn as an input stream")),in_raw_ctx, (fun data _ ~depth -> try let filename, outch = Filename.open_temp_file "elpi" "tmp" in @@ -692,7 +778,7 @@ let lp_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("lookahead", In(in_stream, "InStream", Out(string, "NextChar", - Easy "peeks one byte from InStream")), + Easy "peeks one byte from InStream")),in_raw_ctx, (fun (i,_) _ ~depth -> try let pos = pos_in i in @@ -709,8 +795,8 @@ let lp_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("string_to_term", In(string, "S", Out(any, "T", - Full(ContextualConversion.unit_ctx, "parses a term T from S"))), - (fun s _ ~depth () () state -> + Full("parses a term T from S"))),in_raw_ctx, + (fun s _ ~depth _ _ state -> try let loc = Ast.Loc.initial "(string_of_term)" in let t = Parse.goal loc s in @@ -723,8 +809,8 @@ let lp_builtins = let open BuiltIn in let open BuiltInData in [ MLCode(Pred("readterm", In(in_stream, "InStream", Out(any, "T", - Full(ContextualConversion.unit_ctx, "reads T from InStream"))), - (fun (i,source_name) _ ~depth () () state -> + Full("reads T from InStream"))),in_raw_ctx, + (fun (i,source_name) _ ~depth _ _ state -> try let loc = Ast.Loc.initial source_name in let strm = Stream.of_channel i in @@ -747,22 +833,22 @@ let lp_builtins = let open BuiltIn in let open BuiltInData in [ (** ELPI specific built-in ************************************************ *) -let elpi_builtins = let open BuiltIn in let open BuiltInData in let open ContextualConversion in [ +let elpi_builtins = let open BuiltIn in let open BuiltInData in let open Conversion in [ LPDoc "== Elpi builtins ====================================="; MLCode(Pred("dprint", - VariadicIn(unit_ctx, !> any, "prints raw terms (debugging)"), + VariadicIn(any, "prints raw terms (debugging)"),in_raw_ctx, (fun args ~depth _ _ state -> - Format.fprintf Format.std_formatter "@[%a@]@\n%!" + Utils.printf "@[%a@]@\n%!" (RawPp.list (RawPp.Debug.term depth) " ") args ; state, ())), DocAbove); MLCode(Pred("print", - VariadicIn(unit_ctx, !> any,"prints terms"), + VariadicIn(any,"prints terms"),in_raw_ctx, (fun args ~depth _ _ state -> - Format.fprintf Format.std_formatter "@[%a@]@\n%!" + Utils.printf "@[%a@]@\n%!" (RawPp.list (RawPp.term depth) " ") args ; state, ())), DocAbove); @@ -770,7 +856,7 @@ let elpi_builtins = let open BuiltIn in let open BuiltInData in let open Context MLCode(Pred("counter", In (string,"Name", Out(int, "Value", - Easy "reads the Value of a trace point Name")), + Easy "reads the Value of a trace point Name")),in_raw_ctx, (fun s _ ~depth:_ -> !:(Trace_ppx_runtime.Runtime.get_cur_step s))), DocAbove); @@ -778,7 +864,7 @@ let elpi_builtins = let open BuiltIn in let open BuiltInData in let open Context In(string, "Rex", In(string, "Subject", Easy ("checks if Subject matches Rex. "^ - "Matching is based on OCaml's Str library"))), + "Matching is based on OCaml's Str library"))),in_raw_ctx, (fun rex subj ~depth -> let rex = Str.regexp rex in if Str.string_match rex subj 0 then () else raise No_clause)), @@ -790,7 +876,7 @@ let elpi_builtins = let open BuiltIn in let open BuiltInData in let open Context In(string, "Subject", Out(string, "Out", Easy ("Out is obtained by replacing all occurrences of Rex with "^ - "Replacement in Subject. See also OCaml's Str.global_replace"))))), + "Replacement in Subject. See also OCaml's Str.global_replace"))))),in_raw_ctx, (fun rex repl subj _ ~depth -> let rex = Str.regexp rex in !:(Str.global_replace rex repl subj))), @@ -801,8 +887,8 @@ let elpi_builtins = let open BuiltIn in let open BuiltInData in let open Context In(string, "QueryText", Out(list (poly "A"), "QuotedProgram", Out(poly "A", "QuotedQuery", - Full (unit_ctx, "quotes the program from FileName and the QueryText. "^ - "See elpi-quoted_syntax.elpi for the syntax tree"))))), + Full ("quotes the program from FileName and the QueryText. "^ + "See elpi-quoted_syntax.elpi for the syntax tree"))))),in_raw_ctx, (fun f s _ _ ~depth _ _ state -> let elpi, _ = Setup.init ~builtins:[BuiltIn.declare ~file_name:"(dummy)" []] ~basedir:Sys.(getcwd()) [] in try @@ -831,10 +917,11 @@ let ctype = AlgebraicData.declare { constructors = [ K("ctype","",A(BuiltInData.string,N),B (fun x -> x), M (fun ~ok ~ko x -> ok x)) ] -} |> ContextualConversion.(!<) - -let safe = OpaqueData.declare { +} + +let ty, pp, pp_doc, safe = OpaqueData.declare { OpaqueData.name = "safe"; + cname = "safe"; pp = (fun fmt (id,l) -> Format.fprintf fmt "[safe %d: %a]" id (RawPp.list (fun fmt (t,d) -> RawPp.term d fmt t) ";") !l); @@ -844,6 +931,10 @@ let safe = OpaqueData.declare { doc = "Holds data across bracktracking; can only contain closed terms"; constants = []; } +let safe : 'c. ('a, #Conversion.ctx as 'c) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed safe ~depth); + readback = (fun ~depth -> OpaqueData.readback safe ~depth); +} let safeno = ref 0 @@ -898,7 +989,7 @@ and same_term_list ~depth xs ys = | x::xs, y::ys -> same_term ~depth x y && same_term_list ~depth xs ys | _ -> false -let elpi_nonlogical_builtins = let open BuiltIn in let open BuiltInData in let open ContextualConversion in [ +let elpi_nonlogical_builtins = let open BuiltIn in let open BuiltInData in let open Conversion in [ LPDoc "== Elpi nonlogical builtins ====================================="; @@ -906,7 +997,7 @@ let elpi_nonlogical_builtins = let open BuiltIn in let open BuiltInData in let o MLCode(Pred("var", In(any, "V", - Easy "checks if the term V is a variable"), + Easy "checks if the term V is a variable"),in_raw_ctx, (fun t1 ~depth -> match look ~depth t1 with | UnifVar _ -> () @@ -916,7 +1007,7 @@ let elpi_nonlogical_builtins = let open BuiltIn in let open BuiltInData in let o MLCode(Pred("same_var", In(poly "A", "V1", In(poly "A", "V2", - Easy "checks if the two terms V1 and V2 are the same variable, ignoring the arguments of the variables")), + Easy "checks if the two terms V1 and V2 are the same variable, ignoring the arguments of the variables")),in_raw_ctx, (fun t1 t2 ~depth -> match look ~depth t1, look ~depth t2 with | UnifVar(p1,_), UnifVar (p2,_) when FlexibleData.Elpi.equal p1 p2 -> () @@ -926,7 +1017,7 @@ let elpi_nonlogical_builtins = let open BuiltIn in let open BuiltInData in let o MLCode(Pred("same_term", In(poly "A", "T1", In(poly "A", "T2", - Easy {|checks if the two terms T1 and T2 are syntactically equal (no unification). It behaves differently than same_var since it recursively compares the arguments of the variables|})), + Easy {|checks if the two terms T1 and T2 are syntactically equal (no unification). It behaves differently than same_var since it recursively compares the arguments of the variables|})),in_raw_ctx, (fun t1 t2 ~depth -> if same_term ~depth t1 t2 then () else raise No_clause)), DocAbove); @@ -941,25 +1032,25 @@ X == Y :- same_term X Y. In(any, "A", In(any, "B", Out(cmp,"Cmp", - Easy "Compares A and B. Only works if A and B are ground."))), + Easy "Compares A and B. Only works if A and B are ground."))),in_raw_ctx, (fun t1 t2 _ ~depth -> !: (cmp_term ~depth t1 t2))), DocAbove); MLCode(Pred("name", InOut(ioarg_any, "T", - VariadicInOut(unit_ctx, !> (ioarg any),"checks if T is a eigenvariable. When used with tree arguments it relates an applied name with its head and argument list.")), + VariadicInOut(ioarg any,"checks if T is a eigenvariable. When used with tree arguments it relates an applied name with its head and argument list.")),in_raw_ctx, (name_or_constant "name" (fun x -> x >= 0))), DocAbove); MLCode(Pred("constant", InOut(ioarg_any, "T", - VariadicInOut(unit_ctx, !> (ioarg any),"checks if T is a (global) constant. When used with tree arguments it relates an applied constant with its head and argument list.")), + VariadicInOut(ioarg any,"checks if T is a (global) constant. When used with tree arguments it relates an applied constant with its head and argument list.")),in_raw_ctx, (name_or_constant "constant" (fun x -> x < 0))), DocAbove); MLCode(Pred("names", Out(list any, "list of eigenvariables in order of age (young first)", - Easy "generates the list of eigenvariable"), + Easy "generates the list of eigenvariable"),in_raw_ctx, (* XXX 4.06: (fun _ ~depth -> !:(List.init depth mkConst))), *) (fun _ ~depth -> let rec list_init i n f = @@ -971,7 +1062,7 @@ X == Y :- same_term X Y. MLCode(Pred("occurs", In(any, "a constant (global or eigenvariable)", In(any, "a term", - Easy "checks if the constant occurs in the term")), + Easy "checks if the constant occurs in the term")),in_raw_ctx, (fun t1 t2 ~depth -> let occurs_in t2 t = match look ~depth t with @@ -982,7 +1073,7 @@ X == Y :- same_term X Y. MLCode(Pred("closed_term", Out(any, "T", - Full (unit_ctx, "unify T with a variable that has no eigenvariables in scope")), + Full ("unify T with a variable that has no eigenvariables in scope")),in_raw_ctx, (fun _ ~depth _ _ state -> let state, k = FlexibleData.Elpi.make state in state, !:(mkUnifVar k ~args:[] state), [])), @@ -990,14 +1081,14 @@ X == Y :- same_term X Y. MLCode(Pred("ground_term", In(any, "T", - Easy ("Checks if T contains unification variables")), + Easy ("Checks if T contains unification variables")),in_raw_ctx, (fun t ~depth -> check_ground ~depth t)), DocAbove); MLCode(Pred("is_cdata", In(any, "T", Out(ctype, "Ctype", - Easy "checks if T is primitive of type Ctype, eg (ctype \"int\")")), + Easy "checks if T is primitive of type Ctype, eg (ctype \"int\")")),in_raw_ctx, (fun t _ ~depth -> match look ~depth t with | CData n -> !:(RawOpaqueData.name n) @@ -1009,7 +1100,7 @@ X == Y :- same_term X Y. MLCode(Pred("new_int", Out(int, "N", - Easy "unifies N with a different int every time it is called. Values of N are guaranteed to be incresing."), + Easy "unifies N with a different int every time it is called. Values of N are guaranteed to be incresing."),in_raw_ctx, (fun _ ~depth -> incr fresh_int; if !fresh_int < 0 then anomaly "new_int: reached max_int"; @@ -1020,21 +1111,21 @@ X == Y :- same_term X Y. MLCode(Pred("new_safe", Out(safe, "Safe", - Easy "creates a safe: a store that persists across backtracking"), + Easy "creates a safe: a store that persists across backtracking"),in_raw_ctx, (fun _ ~depth -> incr safeno; !:(!safeno,ref []))), DocAbove); MLCode(Pred("stash_in_safe", In(safe, "Safe", In(closed "A", "Data", - Easy "stores Data in the Safe")), + Easy "stores Data in the Safe")),in_raw_ctx, (fun (_,l) t ~depth -> l := t :: !l)), DocAbove); MLCode(Pred("open_safe", In(safe, "Safe", Out(list (closed "A"), "Data", - Easy "retrieves the Data stored in Safe")), + Easy "retrieves the Data stored in Safe")),in_raw_ctx, (fun (_,l) _ ~depth -> !:(List.rev !l))), DocAbove); @@ -1047,36 +1138,37 @@ if _ _ E :- E. |}; MLCode(Pred("random.init", In(int, "Seed", - Easy "Initialize OCaml's PRNG with the given Seed"), + Easy "Initialize OCaml's PRNG with the given Seed"),in_raw_ctx, (fun seed ~depth:_ -> Random.init seed)), DocAbove); MLCode(Pred("random.self_init", - Easy "Initialize OCaml's PRNG with some seed", + Easy "Initialize OCaml's PRNG with some seed",in_raw_ctx, (fun ~depth:_ -> Random.self_init ())), DocAbove); MLCode(Pred("random.int", In(int, "Bound", Out(int, "N", - Easy "unifies N with a random int between 0 and Bound (excluded)")), + Easy "unifies N with a random int between 0 and Bound (excluded)")),in_raw_ctx, (fun bound _ ~depth -> !: (Random.int bound))), DocAbove); ] ;; -let elpi_stdlib_src = let open BuiltIn in let open BuiltInData in [ +let elpi_stdlib_src = let open BuiltIn in let open BuiltInData in [ LPCode Builtin_stdlib.code ] let ocaml_set ~name (type a) - (alpha : a Conversion.t) (module Set : Util.Set.S with type elt = a) = - -let set = OpaqueData.declare { + (alpha : (a,Conversion.ctx) Conversion.t) (module Set : Util.Set.S with type elt = a) = + +let ty, pp, pp_doc, set = OpaqueData.declare { OpaqueData.name; + cname = name; doc = ""; pp = (fun fmt m -> Format.fprintf fmt "%a" Set.pp m ); compare = (fun m1 m2 -> Set.compare m1 m2); @@ -1084,24 +1176,26 @@ let set = OpaqueData.declare { hconsed = false; constants = []; } in +let set : (Set.t, #Conversion.ctx as 'c) Conversion.t = { Conversion.ty; pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed set ~depth); + readback = (fun ~depth -> OpaqueData.readback set ~depth); +} in -let set = { set with Conversion.ty = Conversion.(TyName name) } in - -let open BuiltIn in let open BuiltInData in +let open BuiltIn in let open BuiltInData in let open Conversion in [ LPCode ("kind "^name^" type."); MLCode(Pred(name^".empty", Out(set,"A", - Easy "The empty set"), + Easy "The empty set"),in_raw_ctx, (fun _ ~depth -> !: Set.empty)), DocAbove); MLCode(Pred(name^".mem", In(alpha,"Elem", In(set,"A", - Easy "Checks if Elem is in a")), + Easy "Checks if Elem is in a")),in_raw_ctx, (fun s m ~depth -> if Set.mem s m then () else raise No_clause)), DocAbove); @@ -1110,7 +1204,7 @@ let open BuiltIn in let open BuiltInData in In(alpha,"Elem", In(set,"A", Out(set,"B", - Easy "B is A union {Elem}"))), + Easy "B is A union {Elem}"))),in_raw_ctx, (fun s m _ ~depth -> !: (Set.add s m))), DocAbove); @@ -1118,7 +1212,7 @@ let open BuiltIn in let open BuiltInData in In(alpha,"Elem", In(set,"A", Out(set,"B", - Easy "B is A \ {Elem}"))), + Easy "B is A \ {Elem}"))),in_raw_ctx, (fun s m _ ~depth -> !: (Set.remove s m))), DocAbove); @@ -1126,7 +1220,7 @@ let open BuiltIn in let open BuiltInData in In(set,"A", In(set,"B", Out(set,"X", - Easy "X is A union B"))), + Easy "X is A union B"))),in_raw_ctx, (fun a b _ ~depth -> !: (Set.union a b))), DocAbove); @@ -1134,7 +1228,7 @@ let open BuiltIn in let open BuiltInData in In(set,"A", In(set,"B", Out(set,"X", - Easy "X is A intersection B"))), + Easy "X is A intersection B"))),in_raw_ctx, (fun a b _ ~depth -> !: (Set.inter a b))), DocAbove); @@ -1142,47 +1236,48 @@ let open BuiltIn in let open BuiltInData in In(set,"A", In(set,"B", Out(set,"X", - Easy "X is A \ B"))), + Easy "X is A \ B"))),in_raw_ctx, (fun a b _ ~depth -> !: (Set.diff a b))), DocAbove); MLCode(Pred(name^".equal", In(set,"A", In(set,"B", - Easy "tests A and B for equality")), + Easy "tests A and B for equality")),in_raw_ctx, (fun a b ~depth -> if Set.equal a b then () else raise No_clause)), DocAbove); MLCode(Pred(name^".subset", In(set,"A", In(set,"B", - Easy "tests if A is a subset of B")), + Easy "tests if A is a subset of B")),in_raw_ctx, (fun a b ~depth -> if Set.subset a b then () else raise No_clause)), DocAbove); MLCode(Pred(name^".elements", In(set,"M", Out(list alpha,"L", - Easy "L is M transformed into list")), + Easy "L is M transformed into list")),in_raw_ctx, (fun m _ ~depth -> !: (Set.elements m))), DocAbove); MLCode(Pred(name^".cardinal", In(set,"M", Out(int,"N", - Easy "N is the number of elements of M")), + Easy "N is the number of elements of M")),in_raw_ctx, (fun m _ ~depth -> !: (Set.cardinal m))), DocAbove); -] +] ;; let ocaml_map ~name (type a) - (alpha : a Conversion.t) (module Map : Util.Map.S with type key = a) = - + (alpha : (a,Conversion.ctx) Conversion.t) (module Map : Util.Map.S with type key = a) = + let closed_A = BuiltInData.closed "A" in -let map = OpaqueData.declare { +let ty, pp, pp_doc, map = OpaqueData.declare { OpaqueData.name; + cname = name; doc = ""; pp = (fun fmt m -> Format.fprintf fmt "%a" (Map.pp closed_A.pp) m ); compare = (fun m1 m2 -> Map.compare Pervasives.compare m1 m2); @@ -1190,11 +1285,14 @@ let map = OpaqueData.declare { hconsed = false; constants = []; } in +let map a = { + Conversion.ty = Conversion.(TyApp(name,TyName a,[])); + pp; pp_doc; + embed = (fun ~depth -> OpaqueData.embed map ~depth); + readback = (fun ~depth -> OpaqueData.readback map ~depth); +} in -let map a = { map with - Conversion.ty = Conversion.(TyApp(name,TyName a,[])) } in - -let open BuiltIn in let open BuiltInData in +let open BuiltIn in let open BuiltInData in let open Conversion in [ LPDoc ("CAVEAT: the type parameter of "^name^" must be a closed term"); @@ -1202,14 +1300,14 @@ let open BuiltIn in let open BuiltInData in MLCode(Pred(name^".empty", Out(map "A","M", - Easy "The empty map"), + Easy "The empty map"),in_raw_ctx, (fun _ ~depth -> !: Map.empty)), DocAbove); MLCode(Pred(name^".mem", In(alpha,"S", In(map "A","M", - Easy "Checks if S is bound in M")), + Easy "Checks if S is bound in M")),in_raw_ctx, (fun s m ~depth -> if Map.mem s m then () else raise No_clause)), DocAbove); @@ -1219,7 +1317,7 @@ let open BuiltIn in let open BuiltInData in In(closed_A,"V", In(map "A","M", Out(map "A","M1", - Easy "M1 is M where V is bound to S")))), + Easy "M1 is M where V is bound to S")))),in_raw_ctx, (fun s l m _ ~depth -> !: (Map.add s l m))), DocAbove); @@ -1227,7 +1325,7 @@ let open BuiltIn in let open BuiltInData in In(alpha,"S", In(map "A","M", Out(map "A","M1", - Easy "M1 is M where S is unbound"))), + Easy "M1 is M where S is unbound"))),in_raw_ctx, (fun s m _ ~depth -> !: (Map.remove s m))), DocAbove); @@ -1235,7 +1333,7 @@ let open BuiltIn in let open BuiltInData in In(alpha,"S", In(map "A","M", Out(closed_A,"V", - Easy "V is the binding of S in M"))), + Easy "V is the binding of S in M"))),in_raw_ctx, (fun s m _ ~depth -> try !: (Map.find s m) with Not_found -> raise No_clause)), @@ -1244,36 +1342,35 @@ let open BuiltIn in let open BuiltInData in MLCode(Pred(name^".bindings", In(map "A","M", Out(list (pair alpha (closed_A)),"L", - Easy "L is M transformed into an associative list")), + Easy "L is M transformed into an associative list")),in_raw_ctx, (fun m _ ~depth -> !: (Map.bindings m))), DocAbove); -] +] ;; module LocMap : Util.Map.S with type key = Ast.Loc.t = Util.Map.Make(Ast.Loc) module LocSet : Util.Set.S with type elt = Ast.Loc.t = Util.Set.Make(Ast.Loc) let elpi_map = let open BuiltIn in let open BuiltInData in [ - + LPCode Builtin_map.code - + ] let elpi_set = let open BuiltIn in let open BuiltInData in [ - + LPCode Builtin_set.code - -] +] let elpi_stdlib = elpi_stdlib_src @ - ocaml_map ~name:"std.string.map" BuiltInData.string (module Util.StrMap) @ - ocaml_map ~name:"std.int.map" BuiltInData.int (module Util.IntMap) @ - ocaml_map ~name:"std.loc.map" BuiltInData.loc (module LocMap) @ - ocaml_set ~name:"std.string.set" BuiltInData.string (module Util.StrSet) @ - ocaml_set ~name:"std.int.set" BuiltInData.int (module Util.IntSet) @ + ocaml_map ~name:"std.string.map" BuiltInData.string (module Util.StrMap) @ + ocaml_map ~name:"std.int.map" BuiltInData.int (module Util.IntMap) @ + ocaml_map ~name:"std.loc.map" BuiltInData.loc (module LocMap) @ + ocaml_set ~name:"std.string.set" BuiltInData.string (module Util.StrSet) @ + ocaml_set ~name:"std.int.set" BuiltInData.int (module Util.IntSet) @ ocaml_set ~name:"std.loc.set" BuiltInData.loc (module LocSet) @ [] ;; diff --git a/src/builtin.mli b/src/builtin.mli index 2513d4501..e357bef06 100644 --- a/src/builtin.mli +++ b/src/builtin.mli @@ -33,11 +33,11 @@ val elpi_set : declaration list ocaml_map ~name:"strmap" BuiltInData.string (module StrMap) *) val ocaml_map : name:string -> - 'a API.Conversion.t -> (module API.Utils.Map.S with type key = 'a) -> + ('a, API.Conversion.ctx) API.Conversion.t -> (module API.Utils.Map.S with type key = 'a) -> declaration list val ocaml_set : name:string -> - 'a API.Conversion.t -> (module API.Utils.Set.S with type elt = 'a) -> + ('a, API.Conversion.ctx) API.Conversion.t -> (module API.Utils.Set.S with type elt = 'a) -> declaration list (* All the above, to be used as a sane default in Setup.init *) @@ -45,18 +45,12 @@ val std_declarations : declaration list val std_builtins : API.Setup.builtins (* Type descriptors for built-in predicates *) -val pair : 'a API.Conversion.t -> 'b API.Conversion.t -> ('a * 'b) API.Conversion.t -val option : 'a API.Conversion.t -> 'a option API.Conversion.t -val bool : bool API.Conversion.t - -type diagnostic = private OK | ERROR of string API.BuiltInPredicate.ioarg -val diagnostic : diagnostic API.Conversion.t -val mkOK : diagnostic -val mkERROR : string -> diagnostic - -(* The string is the "file name" *) -val in_stream : (in_channel * string) API.Conversion.t -val out_stream : (out_channel * string) API.Conversion.t +val pair : ('a,'c) API.Conversion.t -> ('b,'c) API.Conversion.t -> ('a * 'b, 'c) API.Conversion.t +val option : ('a,'c) API.Conversion.t -> ('a option,'c) API.Conversion.t + +val triple : ('a, 'h) API.Conversion.t -> ('b, 'h) API.Conversion.t -> ('c, 'h) API.Conversion.t -> ('a * 'b * 'c, 'h) API.Conversion.t +val quadruple : ('a, 'h) API.Conversion.t -> ('b, 'h) API.Conversion.t -> ('c, 'h) API.Conversion.t -> ('d, 'h) API.Conversion.t -> ('a * 'b * 'c * 'd, 'h) API.Conversion.t +val quintuple : ('a, 'h) API.Conversion.t -> ('b, 'h) API.Conversion.t -> ('c, 'h) API.Conversion.t -> ('d, 'h) API.Conversion.t -> ('e, 'h) API.Conversion.t -> ('a * 'b * 'c * 'd * 'e, 'h) API.Conversion.t (* This is the default checker [elpi-checker] *) val default_checker : unit -> API.Compile.program diff --git a/src/builtin_map.elpi b/src/builtin_map.elpi index 9566e4652..f233202a7 100644 --- a/src/builtin_map.elpi +++ b/src/builtin_map.elpi @@ -3,7 +3,7 @@ type std.map std.map.private.map K V -> (K -> K -> cmp -> prop) -> std.map K V. namespace std.map { -% [make Eq Ltn M] builds an empty map M where keys are compared using Eq and Ltn +% [make Cmp M] builds an empty map M where keys are compared using Cmp pred make i:(K -> K -> cmp -> prop), o:std.map K V. make Cmp (std.map private.empty Cmp). diff --git a/src/builtin_set.elpi b/src/builtin_set.elpi index db1337f9a..b0fee421d 100644 --- a/src/builtin_set.elpi +++ b/src/builtin_set.elpi @@ -3,7 +3,7 @@ type std.set std.set.private.set E -> (E -> E -> cmp -> prop) -> std.set E. namespace std.set { -% [make Eq Ltn M] builds an empty set M where keys are compared using Eq and Ltn +% [make Cmp M] builds an empty set M where keys are compared using Cmp pred make i:(E -> E -> cmp -> prop), o:std.set E. make Cmp (std.set private.empty Cmp). diff --git a/src/compiler.ml b/src/compiler.ml index d3e946468..8d09b4bca 100644 --- a/src/compiler.ml +++ b/src/compiler.ml @@ -251,7 +251,7 @@ let builtins : t D.State.component = D.State.declare ~name:"elpi:compiler:builti let all state = (D.State.get builtins state).constants -let register state (D.BuiltInPredicate.Pred(s,_,_) as b) = +let register state (D.BuiltInPredicate.Pred(s,_,_,_) as b) = if s = "" then anomaly "Built-in predicate name must be non empty"; if not (D.State.get D.while_compiling state) then anomaly "Built-in can only be declared at compile time"; @@ -446,7 +446,7 @@ type 'a query = { chr : (constant list * prechr_rule list) list; initial_depth : int; query : preterm; - query_arguments : 'a Query.arguments [@opaque]; + query_readback : 'a query_readback [@opaque]; (* We pre-compile the query to ease the API *) initial_goal : term; assignments : term StrMap.t; compiler_state : State.t; @@ -709,11 +709,11 @@ module ToDBL : sig (* Exported to compile the query *) val query_preterm_of_ast : depth:int -> macro_declaration -> State.t -> - Loc.t * Ast.Term.t -> State.t * preterm + Loc.t * Ast.Term.t -> State.t * preterm * unit query_readback val query_preterm_of_function : depth:int -> macro_declaration -> State.t -> - (State.t -> State.t * (Loc.t * term)) -> - State.t * preterm + (State.t -> State.t * (Loc.t * term) * 'a query_readback) -> + State.t * preterm * 'a query_readback (* Exported for quations *) val lp : quotation @@ -1003,15 +1003,15 @@ let preterms_of_ast ?on_type loc ~depth macros state f t = let query_preterm_of_function ~depth macros state f = assert(is_empty_amap (get_argmap state)); let state = set_mtm state (Some { macros }) in - let state, (loc, term) = f state in + let state, (loc, term), readback = f state in let amap = get_argmap state in - state, { amap; term; loc } + state, { amap; term; loc }, readback let query_preterm_of_ast ~depth macros state (loc, t) = assert(is_empty_amap (get_argmap state)); let state, term = preterm_of_ast loc ~depth macros state t in let amap = get_argmap state in - state, { term; amap; loc } + state, { term; amap; loc }, fun _ _ _ -> () ;; open Ast.Structured @@ -1976,7 +1976,7 @@ let query_of_ast compiler_state assembled_program t = let type_abbrevs = assembled_program.Assembled.type_abbrevs in let modes = assembled_program.Assembled.modes in let active_macros = assembled_program.Assembled.toplevel_macros in - let state, query = + let state, query, query_readback = ToDBL.query_preterm_of_ast ~depth:initial_depth active_macros compiler_state t in let query = Spill.spill_preterm state types (fun c -> C.Map.find c modes) query in let query_env = Array.make query.amap.nargs D.dummy in @@ -1993,7 +1993,7 @@ let query_of_ast compiler_state assembled_program t = chr = assembled_program.Assembled.chr; initial_depth; query; - query_arguments = Query.N; + query_readback; initial_goal; assignments; compiler_state = state |> (uvbodies_of_assignments assignments); @@ -2005,10 +2005,10 @@ let query_of_term compiler_state assembled_program f = let type_abbrevs = assembled_program.Assembled.type_abbrevs in let modes = assembled_program.Assembled.modes in let active_macros = assembled_program.Assembled.toplevel_macros in - let state, query = + let state, query, query_readback = ToDBL.query_preterm_of_function ~depth:initial_depth active_macros compiler_state - (f ~depth:initial_depth) in + (f ~depth:initial_depth [] []) in let query_env = Array.make query.amap.nargs D.dummy in let state, queryt = stack_term_of_preterm ~depth:initial_depth state query in let initial_goal = @@ -2023,18 +2023,17 @@ let query_of_term compiler_state assembled_program f = chr = assembled_program.Assembled.chr; initial_depth; query; - query_arguments = Query.N; + query_readback; initial_goal; assignments; compiler_state = state |> (uvbodies_of_assignments assignments); } -let query_of_data state p loc (Query.Query { arguments } as descr) = - let query = query_of_term state p (fun ~depth state -> - let state, term = R.embed_query ~mk_Arg ~depth state descr in - state, (loc, term)) in - { query with query_arguments = arguments } +let query_of_data state p loc qdescr = + query_of_term state p (fun ~depth hyps constraints state -> + let (state, term), query_readback = R.embed_query ~mk_Arg ~depth hyps constraints state qdescr in + state, (loc, term), query_readback) module Compiler : sig @@ -2118,7 +2117,7 @@ let run initial_goal; assignments; compiler_state = state; - query_arguments; + query_readback; } = let flags = State.get compiler_flags state in @@ -2160,7 +2159,7 @@ let run let builtins = Hashtbl.create 17 in let pred_list = (State.get Builtins.builtins state).code in List.iter - (fun (D.BuiltInPredicate.Pred(s,_,_) as p) -> + (fun (D.BuiltInPredicate.Pred(s,_,_,_) as p) -> let c, _ = Symbols.get_global_symbol_str state s in Hashtbl.add builtins c p) pred_list; @@ -2172,7 +2171,7 @@ let run initial_goal; initial_runtime_state = State.end_compilation state; assignments; - query_arguments; + query_readback; symbol_table; builtins; } @@ -2366,7 +2365,7 @@ let term_of_ast ~depth state t = if State.get D.while_compiling state then anomaly ("term_of_ast cannot be used at compilation time"); let state, (t,nargs) = ToDBL.temporary_compilation_at_runtime (fun s x -> - let s, x = ToDBL.query_preterm_of_ast ~depth F.Map.empty s x in + let s, x, _ = ToDBL.query_preterm_of_ast ~depth F.Map.empty s x in let s, t = stack_term_of_preterm ~depth s x in s, (t, x.amap.nargs) ) state t in @@ -2395,9 +2394,9 @@ let static_check ~exec ~checker:(state,program) in let loc = Loc.initial "(static_check)" in let query = - query_of_term state program (fun ~depth state -> + query_of_term state program (fun ~depth hyps constraints state -> assert(depth=0); - state, (loc,App(checkc,R.list_to_lp_list p,[q;R.list_to_lp_list tlist;R.list_to_lp_list talist]))) in + state, (loc,App(checkc,R.list_to_lp_list p,[q;R.list_to_lp_list tlist;R.list_to_lp_list talist])), (fun _ _ _ -> ())) in let executable = optimize_query query in exec executable <> Failure ;; diff --git a/src/compiler.mli b/src/compiler.mli index 11ae7cd89..159aea148 100644 --- a/src/compiler.mli +++ b/src/compiler.mli @@ -27,7 +27,7 @@ val assemble_units : header:compilation_unit -> compilation_unit list -> State.t val query_of_ast : State.t -> program -> Ast.Goal.t -> unit query val query_of_term : - State.t -> program -> (depth:int -> State.t -> State.t * (Loc.t * term)) -> unit query + State.t -> program -> (depth:int -> hyps -> constraints -> State.t -> State.t * (Loc.t * term) * 'a query_readback) -> 'a query val query_of_data : State.t -> program -> Loc.t -> 'a Query.t -> 'a query val optimize_query : 'a query -> 'a executable diff --git a/src/data.ml b/src/data.ml index 91d6a63f3..7a9e3b85a 100644 --- a/src/data.ml +++ b/src/data.ml @@ -541,115 +541,105 @@ module Conversion = struct type ty_ast = TyName of string | TyApp of string * ty_ast * ty_ast list [@@deriving show] - type 'a embedding = - depth:int -> - State.t -> 'a -> State.t * term * extra_goals - - type 'a readback = - depth:int -> - State.t -> term -> State.t * 'a * extra_goals - - type 'a t = { - ty : ty_ast; - pp_doc : Format.formatter -> unit -> unit [@opaque]; - pp : Format.formatter -> 'a -> unit [@opaque]; - embed : 'a embedding [@opaque]; (* 'a -> term *) - readback : 'a readback [@opaque]; (* term -> 'a *) - } - [@@deriving show] - exception TypeErr of ty_ast * int * term (* a type error at data conversion time *) let rec show_ty_ast ?(outer=true) = function | TyName s -> s + | TyApp ("->",x,[y]) -> + "("^ show_ty_ast x ^ " -> " ^ show_ty_ast y ^")" | TyApp (s,x,xs) -> let t = String.concat " " (s :: List.map (show_ty_ast ~outer:false) (x::xs)) in if outer then t else "("^t^")" + class ctx (h : hyps) = + object + method raw = h + end -end - -module ContextualConversion = struct - - type ty_ast = Conversion.ty_ast = TyName of string | TyApp of string * ty_ast * ty_ast list - [@@deriving show] - - type ('a,'hyps,'constraints) embedding = - depth:int -> 'hyps -> 'constraints -> + type ('a,'ctx) embedding = + depth:int -> 'ctx -> constraints -> State.t -> 'a -> State.t * term * extra_goals + constraint 'ctx = #ctx - type ('a,'hyps,'constraints) readback = - depth:int -> 'hyps -> 'constraints -> + type ('a,'ctx) readback = + depth:int -> 'ctx -> constraints -> State.t -> term -> State.t * 'a * extra_goals + constraint 'ctx = #ctx - type ('a,'hyps,'constraints) t = { + type ('a,'ctx) t = { ty : ty_ast; pp_doc : Format.formatter -> unit -> unit [@opaque]; pp : Format.formatter -> 'a -> unit [@opaque]; - embed : ('a,'hyps,'constraints) embedding [@opaque]; (* 'a -> term *) - readback : ('a,'hyps,'constraints) readback [@opaque]; (* term -> 'a *) + embed : ('a,'ctx) embedding [@opaque]; (* 'a -> term *) + readback : ('a,'ctx) readback [@opaque]; (* term -> 'a *) } + constraint 'ctx = #ctx [@@deriving show] - type ('hyps,'constraints) ctx_readback = - depth:int -> hyps -> constraints -> State.t -> State.t * 'hyps * 'constraints * extra_goals + type 'a ctx_entry = { entry : 'a; depth : int } + [@@deriving show] - let unit_ctx : (unit,unit) ctx_readback = fun ~depth:_ _ _ s -> s, (), (), [] - let raw_ctx : (hyps,constraints) ctx_readback = fun ~depth:_ h c s -> s, h, c, [] + type 'a ctx_field = 'a ctx_entry Constants.Map.t + type hyp = clause_src - let (!<) { ty; pp_doc; pp; embed; readback; } = { - Conversion.ty; pp; pp_doc; - embed = (fun ~depth s t -> embed ~depth () () s t); - readback = (fun ~depth s t -> readback ~depth () () s t); + type ('a,'k,'h) context = { + is_entry_for_nominal : hyp -> constant option; + to_key : depth:int -> 'a -> 'k; + push : depth:int -> State.t -> 'k -> 'a ctx_entry -> State.t; + pop : depth:int -> State.t -> 'k -> State.t; + conv : (constant * 'a, #ctx as 'h) t; + init : State.t -> State.t; + get : State.t -> 'a ctx_field } - - let (!>) { Conversion.ty; pp_doc; pp; embed; readback; } = { - ty; pp; pp_doc; - embed = (fun ~depth _ _ s t -> embed ~depth s t); - readback = (fun ~depth _ _ s t -> readback ~depth s t); + type 'ctx ctx_readback = + depth:int -> hyps -> constraints -> State.t -> State.t * 'ctx * extra_goals + constraint 'ctx = #ctx + + type ('a,'ctx) context_builder = + depth:int -> constraints -> 'a list -> State.t -> + State.t * term ctx_entry Constants.Map.t * 'ctx * extra_goals + constraint 'ctx = #ctx + + type dummy = unit + + let dummy = { + ty = TyName "dummy"; + pp = (fun _ _ -> assert false); + pp_doc = (fun _ _ -> assert false); + embed = (fun ~depth _ _ _ _ -> assert false); + readback = (fun ~depth _ _ _ _ -> assert false); } - let (!>>) (f : 'a Conversion.t -> 'b Conversion.t) cc = - let mk h c { ty; pp_doc; pp; embed; readback; } = { - Conversion.ty; pp; pp_doc; - embed = (fun ~depth s t -> embed ~depth h c s t); - readback = (fun ~depth s t -> readback ~depth h c s t); - } in - let mk_pp { ty; pp_doc; pp; } = { - Conversion.ty; pp; pp_doc; - embed = (fun ~depth s t -> assert false); - readback = (fun ~depth s t -> assert false); - } in - let { Conversion.ty; pp; pp_doc } = f (mk_pp cc) in - { - ty; - pp; - pp_doc; - embed = (fun ~depth h c s t -> (f (mk h c cc)).embed ~depth s t); - readback = (fun ~depth h c s t -> (f (mk h c cc)).readback ~depth s t); - } - - let (!>>>) (f : 'a Conversion.t -> 'b Conversion.t -> 'c Conversion.t) cc dd = - let mk h c { ty; pp_doc; pp; embed; readback; } = { - Conversion.ty; pp; pp_doc; - embed = (fun ~depth s t -> embed ~depth h c s t); - readback = (fun ~depth s t -> readback ~depth h c s t); - } in - let mk_pp { ty; pp_doc; pp; } = { - Conversion.ty; pp; pp_doc; - embed = (fun ~depth s t -> assert false); - readback = (fun ~depth s t -> assert false); - } in - let { Conversion.ty; pp; pp_doc } = f (mk_pp cc) (mk_pp dd) in - { - ty; - pp; - pp_doc; - embed = (fun ~depth h c s t -> (f (mk h c cc) (mk h c dd)).embed ~depth s t); - readback = (fun ~depth h c s t -> (f (mk h c cc) (mk h c dd)).readback ~depth s t); + let in_raw = { + is_entry_for_nominal = (fun _ -> None); + to_key = (fun ~depth _ -> ()); + push = (fun ~depth st _ _ -> st); + pop = (fun ~depth st _ -> st); + conv = dummy; + init = (fun st -> st); + get = (fun st -> Constants.Map.empty); } + let build_raw_ctx h s = new ctx h + let in_raw_ctx : ctx ctx_readback = + fun ~depth:_ h c s -> s, build_raw_ctx h s, [] + + let context_builder { conv; to_key; push; init } obj_builder hyps : ('a,'h) context_builder = + let do1 ~depth csts a m st = + let k = to_key ~depth a in + let st = push ~depth st k { depth; entry = a } in + let st, a, gls = conv.embed ~depth hyps csts st (depth,a) in + st, Constants.Map.add depth { depth; entry = a } m, gls in + fun ~depth csts items st -> + let st = init st in + let st, m, glsl_rev, _ = + List.fold_left (fun (st, m, gls, depth) a -> + let st, m, g = do1 ~depth csts a m st in + st, m, g :: gls, depth+1) + (st, Constants.Map.empty, [], depth) items in + st, m, obj_builder st, List.concat (List.rev glsl_rev) + end let while_compiling = State.declare ~name:"elpi:compiling" @@ -668,23 +658,20 @@ type doc = string type 'a oarg = Keep | Discard type 'a ioarg = Data of 'a | NoData -type ('function_type, 'inernal_outtype_in, 'internal_hyps, 'internal_constraints) ffi = - | In : 't Conversion.t * doc * ('i, 'o,'h,'c) ffi -> ('t -> 'i,'o,'h,'c) ffi - | Out : 't Conversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t oarg -> 'i,'o,'h,'c) ffi - | InOut : 't ioarg Conversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t ioarg -> 'i,'o,'h,'c) ffi +type ('function_type, 'inernal_outtype_in, 'internal_hyps) ffi = - | CIn : ('t,'h,'c) ContextualConversion.t * doc * ('i, 'o,'h,'c) ffi -> ('t -> 'i,'o,'h,'c) ffi - | COut : ('t,'h,'c) ContextualConversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t oarg -> 'i,'o,'h,'c) ffi - | CInOut : ('t ioarg,'h,'c) ContextualConversion.t * doc * ('i, 'o * 't option,'h,'c) ffi -> ('t ioarg -> 'i,'o,'h,'c) ffi + | In : ('t,'h) Conversion.t * doc * ('i, 'o,'h) ffi -> ('t -> 'i,'o,'h) ffi + | Out : ('t,'h) Conversion.t * doc * ('i, 'o * 't option,'h) ffi -> ('t oarg -> 'i,'o,'h) ffi + | InOut : ('t ioarg,'h) Conversion.t * doc * ('i, 'o * 't option,'h) ffi -> ('t ioarg -> 'i,'o,'h) ffi - | Easy : doc -> (depth:int -> 'o, 'o,unit,unit) ffi - | Read : ('h,'c) ContextualConversion.ctx_readback * doc -> (depth:int -> 'h -> 'c -> State.t -> 'o, 'o,'h,'c) ffi - | Full : ('h,'c) ContextualConversion.ctx_readback * doc -> (depth:int -> 'h -> 'c -> State.t -> State.t * 'o * extra_goals, 'o,'h,'c) ffi - | VariadicIn : ('h,'c) ContextualConversion.ctx_readback * ('t,'h,'c) ContextualConversion.t * doc -> ('t list -> depth:int -> 'h -> 'c -> State.t -> State.t * 'o, 'o,'h,'c) ffi - | VariadicOut : ('h,'c) ContextualConversion.ctx_readback * ('t,'h,'c) ContextualConversion.t * doc -> ('t oarg list -> depth:int -> 'h -> 'c -> State.t -> State.t * ('o * 't option list option), 'o,'h,'c) ffi - | VariadicInOut : ('h,'c) ContextualConversion.ctx_readback * ('t ioarg,'h,'c) ContextualConversion.t * doc -> ('t ioarg list -> depth:int -> 'h -> 'c -> State.t -> State.t * ('o * 't option list option), 'o,'h,'c) ffi + | Easy : doc -> (depth:int -> 'o, 'o,'h) ffi + | Read : doc -> (depth:int -> 'h -> constraints -> State.t -> 'o, 'o,'h) ffi + | Full : doc -> (depth:int -> 'h -> constraints -> State.t -> State.t * 'o * extra_goals, 'o,'h) ffi + | VariadicIn : ('t,'h) Conversion.t * doc -> ('t list -> depth:int -> 'h -> constraints -> State.t -> State.t * 'o, 'o,'h) ffi + | VariadicOut : ('t,'h) Conversion.t * doc -> ('t oarg list -> depth:int -> 'h -> constraints -> State.t -> State.t * ('o * 't option list option), 'o,'h) ffi + | VariadicInOut : ('t ioarg,'h) Conversion.t * doc -> ('t ioarg list -> depth:int -> 'h -> constraints -> State.t -> State.t * ('o * 't option list option), 'o,'h) ffi -type t = Pred : name * ('a,unit,'h,'c) ffi * 'a -> t +type t = Pred : name * ('a,unit,'h) ffi * 'h Conversion.ctx_readback * 'a -> t type doc_spec = DocAbove | DocNext @@ -723,36 +710,35 @@ type ('build_stateful_t,'build_t) build_t = | B of 'build_t | BS of 'build_stateful_t -type ('stateful_builder,'builder, 'stateful_matcher, 'matcher, 'self, 'hyps,'constraints) constructor_arguments = +type ('stateful_builder,'builder, 'stateful_matcher, 'matcher, 'self, 'ctx) constructor_arguments = (* No arguments *) - | N : (State.t -> State.t * 'self, 'self, State.t -> State.t * term * extra_goals, term, 'self, 'hyps,'constraints) constructor_arguments - (* An argument of type 'a *) - | A : 'a Conversion.t * ('bs,'b, 'ms,'m, 'self, 'hyps,'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps,'constraints) constructor_arguments - (* An argument of type 'a in context 'hyps,'constraints *) - | CA : ('a,'hyps,'constraints) ContextualConversion.t * ('bs,'b, 'ms,'m, 'self, 'hyps,'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'hyps,'constraints) constructor_arguments + | N : (State.t -> State.t * 'self, 'self, State.t -> State.t * term * extra_goals, term, 'self, 'ctx) constructor_arguments + (* An argument of type 'a in context 'ctx *) + | A : ('a,'ctx) Conversion.t * ('bs,'b, 'ms,'m, 'self, 'ctx) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms, 'a -> 'm, 'self, 'ctx) constructor_arguments (* An argument of type 'self *) - | S : ('bs,'b, 'ms, 'm, 'self, 'hyps,'constraints) constructor_arguments -> ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, 'hyps,'constraints) constructor_arguments + | S : ('bs,'b, 'ms, 'm, 'self, 'ctx) constructor_arguments -> ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, 'ctx) constructor_arguments (* An argument of type `T 'self` for a constainer `T`, like a `list 'self`. `S args` above is a shortcut for `C(fun x -> x, args)` *) - | C : (('self,'hyps,'constraints) ContextualConversion.t -> ('a,'hyps,'constraints) ContextualConversion.t) * ('bs,'b,'ms,'m,'self, 'hyps,'constraints) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms,'a -> 'm, 'self, 'hyps,'constraints) constructor_arguments + | C : (('self,Conversion.ctx) Conversion.t -> ('a,Conversion.ctx) Conversion.t) * ('bs,'b,'ms,'m,'self, 'ctx) constructor_arguments -> ('a -> 'bs, 'a -> 'b, 'a -> 'ms,'a -> 'm, 'self, 'ctx) constructor_arguments -type ('t,'h,'c) constructor = +type ('t,'h) constructor = K : name * doc * - ('build_stateful_t,'build_t,'match_stateful_t,'match_t,'t,'h,'c) constructor_arguments * (* args ty *) + ('build_stateful_t,'build_t,'match_stateful_t,'match_t,'t,'h) constructor_arguments * (* args ty *) ('build_stateful_t,'build_t) build_t * ('match_stateful_t,'match_t,'t) match_t - -> ('t,'h,'c) constructor + -> ('t,'h) constructor -type ('t,'h,'c) declaration = { +type ('t,'h) declaration = { ty : Conversion.ty_ast; doc : doc; pp : Format.formatter -> 't -> unit; - constructors : ('t,'h,'c) constructor list; + constructors : ('t,'h) constructor list; } +constraint 'h = #Conversion.ctx -type ('b,'m,'t,'h,'c) compiled_constructor_arguments = - | XN : (State.t -> State.t * 't,State.t -> State.t * term * extra_goals, 't,'h,'c) compiled_constructor_arguments - | XA : ('a,'h,'c) ContextualConversion.t * ('b,'m,'t,'h,'c) compiled_constructor_arguments -> ('a -> 'b, 'a -> 'm, 't,'h,'c) compiled_constructor_arguments +type ('b,'m,'t,'h) compiled_constructor_arguments = + | XN : (State.t -> State.t * 't,State.t -> State.t * term * extra_goals, 't,'h) compiled_constructor_arguments + | XA : ('a,'h) Conversion.t * ('b,'m,'t,'h) compiled_constructor_arguments -> ('a -> 'b, 'a -> 'm, 't,'h) compiled_constructor_arguments type ('match_t, 't) compiled_match_t = (* continuation to call passing subterms *) @@ -762,21 +748,21 @@ type ('match_t, 't) compiled_match_t = (* match 't and pass its subterms to ~ok or just call ~ko *) 't -> State.t -> State.t * term * extra_goals -type ('t,'h,'c) compiled_constructor = - XK : ('build_t,'matched_t,'t,'h,'c) compiled_constructor_arguments * +type ('t,'h) compiled_constructor = + XK : ('build_t,'matched_t,'t,'h) compiled_constructor_arguments * 'build_t * ('matched_t,'t) compiled_match_t - -> ('t,'h,'c) compiled_constructor + -> ('t,'h) compiled_constructor -type ('t,'h,'c) compiled_adt = (('t,'h,'c) compiled_constructor) Constants.Map.t +type ('t,'h) compiled_adt = (('t,'h) compiled_constructor) Constants.Map.t let buildk ~mkConst kname = function | [] -> mkConst kname | x :: xs -> mkApp kname x xs -let rec readback_args : type a m t h c. +let rec readback_args : type a m t. look:(depth:int -> term -> term) -> - Conversion.ty_ast -> depth:int -> h -> c -> State.t -> extra_goals list -> term -> - (a,m,t,h,c) compiled_constructor_arguments -> a -> term list -> + Conversion.ty_ast -> depth:int -> #Conversion.ctx -> constraints -> State.t -> extra_goals list -> term -> + (a,m,t,Conversion.ctx) compiled_constructor_arguments -> a -> term list -> State.t * t * extra_goals = fun ~look ty ~depth hyps constraints state extra origin args convert l -> match args, l with @@ -790,12 +776,12 @@ let rec readback_args : type a m t h c. readback_args ~look ty ~depth hyps constraints state (gls :: extra) origin rest (convert x) xs -and readback : type t h c. +and readback : type t. mkinterval:(int -> int -> int -> term list) -> look:(depth:int -> term -> term) -> alloc:(?name:string -> State.t -> State.t * 'uk) -> mkUnifVar:('uk -> args:term list -> State.t -> term) -> - Conversion.ty_ast -> (t,h,c) compiled_adt -> depth:int -> h -> c -> State.t -> term -> + Conversion.ty_ast -> (t,Conversion.ctx) compiled_adt -> depth:int -> #Conversion.ctx -> constraints -> State.t -> term -> State.t * t * extra_goals = fun ~mkinterval ~look ~alloc ~mkUnifVar ty adt ~depth hyps constraints state t -> try match look ~depth t with @@ -816,11 +802,11 @@ and readback : type t h c. | _ -> raise (Conversion.TypeErr(ty,depth,t)) with Not_found -> raise (Conversion.TypeErr(ty,depth,t)) -and adt_embed_args : type m a t h c. +and adt_embed_args : type m a t. mkConst:(int -> term) -> - Conversion.ty_ast -> (t,h,c) compiled_adt -> constant -> - depth:int -> h -> c -> - (a,m,t,h,c) compiled_constructor_arguments -> + Conversion.ty_ast -> (t,Conversion.ctx) compiled_adt -> constant -> + depth:int -> #Conversion.ctx -> constraints -> + (a,m,t,Conversion.ctx) compiled_constructor_arguments -> (State.t -> State.t * term * extra_goals) list -> m = fun ~mkConst ty adt kname ~depth hyps constraints args acc -> @@ -837,11 +823,11 @@ and adt_embed_args : type m a t h c. adt_embed_args ~mkConst ty adt kname ~depth hyps constraints args ((fun state -> d.embed ~depth hyps constraints state x) :: acc) -and embed : type a h c. +and embed : type a. mkConst:(int -> term) -> Conversion.ty_ast -> (Format.formatter -> a -> unit) -> - (a,h,c) compiled_adt -> - depth:int -> h -> c -> State.t -> + (a,Conversion.ctx) compiled_adt -> + depth:int -> #Conversion.ctx -> constraints -> State.t -> a -> State.t * term * extra_goals = fun ~mkConst ty pp adt -> let bindings = Constants.Map.bindings adt in @@ -855,32 +841,30 @@ and embed : type a h c. matcher ~ok ~ko:(aux rest) t state in aux bindings state -let rec compile_arguments : type b bs m ms t h c. - (bs,b,ms,m,t,h,c) constructor_arguments -> (t,h,c) ContextualConversion.t -> (bs,ms,t,h,c) compiled_constructor_arguments = +let rec compile_arguments : type b bs m ms t. + (bs,b,ms,m,t,Conversion.ctx) constructor_arguments -> (t,#Conversion.ctx) Conversion.t -> (bs,ms,t,Conversion.ctx) compiled_constructor_arguments = fun arg self -> match arg with | N -> XN - | A(d,rest) -> XA(ContextualConversion.(!>) d,compile_arguments rest self) - | CA(d,rest) -> XA(d,compile_arguments rest self) + | A(d,rest) -> XA(d,compile_arguments rest self) | S rest -> XA(self,compile_arguments rest self) | C(fs, rest) -> XA(fs self, compile_arguments rest self) -let rec compile_builder_aux : type bs b m ms t h c. (bs,b,ms,m,t,h,c) constructor_arguments -> b -> bs +let rec compile_builder_aux : type bs b m ms t h. (bs,b,ms,m,t,h) constructor_arguments -> b -> bs = fun args f -> match args with | N -> fun state -> state, f | A(_,rest) -> fun a -> compile_builder_aux rest (f a) - | CA(_,rest) -> fun a -> compile_builder_aux rest (f a) | S rest -> fun a -> compile_builder_aux rest (f a) | C(_,rest) -> fun a -> compile_builder_aux rest (f a) -let compile_builder : type bs b m ms t h c. (bs,b,ms,m,t,h,c) constructor_arguments -> (bs,b) build_t -> bs +let compile_builder : type bs b m ms t h. (bs,b,ms,m,t,h) constructor_arguments -> (bs,b) build_t -> bs = fun a -> function | B f -> compile_builder_aux a f | BS f -> f -let rec compile_matcher_ok : type bs b m ms t h c. - (bs,b,ms,m,t,h,c) constructor_arguments -> ms -> extra_goals ref -> State.t ref -> m +let rec compile_matcher_ok : type bs b m ms t h. + (bs,b,ms,m,t,h) constructor_arguments -> ms -> extra_goals ref -> State.t ref -> m = fun args f gls state -> match args with | N -> let state', t, gls' = f !state in @@ -888,7 +872,6 @@ let rec compile_matcher_ok : type bs b m ms t h c. gls := gls'; t | A(_,rest) -> fun a -> compile_matcher_ok rest (f a) gls state - | CA(_,rest) -> fun a -> compile_matcher_ok rest (f a) gls state | S rest -> fun a -> compile_matcher_ok rest (f a) gls state | C(_,rest) -> fun a -> compile_matcher_ok rest (f a) gls state @@ -898,7 +881,7 @@ let compile_matcher_ko f gls state () = gls := gls'; t -let compile_matcher : type bs b m ms t h c. (bs,b,ms,m,t,h,c) constructor_arguments -> (ms,m,t) match_t -> (ms,t) compiled_match_t +let compile_matcher : type bs b m ms t h. (bs,b,ms,m,t,h) constructor_arguments -> (ms,m,t) match_t -> (ms,t) compiled_match_t = fun a -> function | M f -> fun ~ok ~ko t state -> @@ -908,7 +891,7 @@ let compile_matcher : type bs b m ms t h c. (bs,b,ms,m,t,h,c) constructor_argume ~ko:(compile_matcher_ko ko gls state) t, !gls | MS f -> f -let rec tyargs_of_args : type a b c d e. string -> (a,b,c,d,e) compiled_constructor_arguments -> (bool * string * string) list = +let rec tyargs_of_args : type a b c d. string -> (a,b,c,d) compiled_constructor_arguments -> (bool * string * string) list = fun self -> function | XN -> [false,self,""] | XA ({ ty },rest) -> (false,Conversion.show_ty_ast ty,"") :: tyargs_of_args self rest @@ -925,11 +908,20 @@ let compile_constructors ty self self_name l = StrMap.add name (tyargs_of_args self_name args) sacc) (Constants.Map.empty,StrMap.empty) l +let document_compiled_constructor fmt name doc argsdoc = + Fmt.fprintf fmt "@[type %s@[%a.%s@]@]@\n" + name pp_ty_args argsdoc (if doc = "" then "" else " % " ^ doc) + let document_constructor fmt name doc argsdoc = + let pp_ty sep fmt s = Fmt.fprintf fmt " %s%s" s sep in + let pp_ty_args = pplist (pp_ty "") " ->" ~pplastelem:(pp_ty "") in Fmt.fprintf fmt "@[type %s@[%a.%s@]@]@\n" name pp_ty_args argsdoc (if doc = "" then "" else " % " ^ doc) -let document_kind fmt = function +let document_kind fmt ty doc = + if doc <> "" then + begin pp_comment fmt ("% " ^ doc); Fmt.fprintf fmt "@\n" end; + match ty with | Conversion.TyApp(s,_,l) -> let n = List.length l + 2 in let l = Array.init n (fun _ -> "type") in @@ -937,24 +929,26 @@ let document_kind fmt = function s (String.concat " -> " (Array.to_list l)) | Conversion.TyName s -> Fmt.fprintf fmt "@[kind %s type.@]@\n" s -let document_adt doc ty ks cks fmt () = - if doc <> "" then - begin pp_comment fmt ("% " ^ doc); Fmt.fprintf fmt "@\n" end; - document_kind fmt ty; +let document_compiled_adt doc ty ks cks fmt () = + document_kind fmt ty doc; List.iter (fun (K(name,doc,_,_,_)) -> if name <> "uvar" then let argsdoc = StrMap.find name cks in - document_constructor fmt name doc argsdoc) ks + document_compiled_constructor fmt name doc argsdoc) ks + +let document_adt doc ty ks fmt () = + document_kind fmt ty doc; + List.iter (fun (name,doc,spec) -> document_constructor fmt name doc spec) ks let adt ~mkinterval ~look ~mkConst ~alloc ~mkUnifVar { ty; constructors; doc; pp } = let readback_ref = ref (fun ~depth _ _ _ _ -> assert false) in let embed_ref = ref (fun ~depth _ _ _ _ -> assert false) in let sconstructors_ref = ref StrMap.empty in let self = { - ContextualConversion.ty; + Conversion.ty; pp; pp_doc = (fun fmt () -> - document_adt doc ty constructors !sconstructors_ref fmt ()); + document_compiled_adt doc ty constructors !sconstructors_ref fmt ()); readback = (fun ~depth hyps constraints state term -> !readback_ref ~depth hyps constraints state term); embed = (fun ~depth hyps constraints state term -> @@ -970,8 +964,7 @@ end type declaration = | MLCode of t * doc_spec - | MLData : 'a Conversion.t -> declaration - | MLDataC : ('a,'h,'c) ContextualConversion.t -> declaration + | MLData : ('a,'h) Conversion.t -> declaration | LPDoc of string | LPCode of string @@ -1027,20 +1020,17 @@ let pp_variadictype fmt name doc_pred ty args = let document_pred fmt docspec name ffi = let rec doc - : type i o h c. (bool * string * string) list -> (i,o,h,c) ffi -> unit + : type i o h. (bool * string * string) list -> (i,o,h) ffi -> unit = fun args -> function | In( { Conversion.ty }, s, ffi) -> doc ((true,Conversion.show_ty_ast ty,s) :: args) ffi | Out( { Conversion.ty }, s, ffi) -> doc ((false,Conversion.show_ty_ast ty,s) :: args) ffi | InOut( { Conversion.ty }, s, ffi) -> doc ((false,Conversion.show_ty_ast ty,s) :: args) ffi - | CIn( { ContextualConversion.ty }, s, ffi) -> doc ((true,Conversion.show_ty_ast ty,s) :: args) ffi - | COut( { ContextualConversion.ty }, s, ffi) -> doc ((false,Conversion.show_ty_ast ty,s) :: args) ffi - | CInOut( { ContextualConversion.ty }, s, ffi) -> doc ((false,Conversion.show_ty_ast ty,s) :: args) ffi - | Read (_,s) -> pp_pred fmt docspec name s args + | Read s -> pp_pred fmt docspec name s args | Easy s -> pp_pred fmt docspec name s args - | Full (_,s) -> pp_pred fmt docspec name s args - | VariadicIn( _,{ ContextualConversion.ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args - | VariadicOut( _,{ ContextualConversion.ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args - | VariadicInOut( _,{ ContextualConversion.ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args + | Full s -> pp_pred fmt docspec name s args + | VariadicIn( { Conversion.ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args + | VariadicOut( { Conversion.ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args + | VariadicInOut( { Conversion.ty }, s) -> pp_variadictype fmt name s (Conversion.show_ty_ast ty) args in doc [] ffi ;; @@ -1051,9 +1041,8 @@ let document fmt l = Fmt.fprintf fmt "@["; Fmt.fprintf fmt "@\n@\n"; List.iter (function - | MLCode(Pred(name,ffi,_), docspec) -> document_pred fmt docspec name ffi + | MLCode(Pred(name,ffi,_,_), docspec) -> document_pred fmt docspec name ffi | MLData { pp_doc } -> Fmt.fprintf fmt "%a@\n" pp_doc () - | MLDataC { pp_doc } -> Fmt.fprintf fmt "%a@\n" pp_doc () | LPCode s -> Fmt.fprintf fmt "%s" s; Fmt.fprintf fmt "@\n@\n" | LPDoc s -> pp_comment fmt ("% " ^ s); Fmt.fprintf fmt "@\n@\n") l; Fmt.fprintf fmt "@\n@\n"; @@ -1067,13 +1056,20 @@ end module Query = struct type name = string - type _ arguments = - | N : unit arguments - | D : 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q : 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments - - type 'x t = - | Query of { predicate : constant; arguments : 'x arguments } + type ('x,'c) arguments = + | N : (unit, 'c) arguments + | D : ('a, #Conversion.ctx as 'c) Conversion.t * 'a * ('x, 'c) arguments -> ('x, 'c) arguments + | Q : ('a, #Conversion.ctx as 'c) Conversion.t * name * ('x, 'c) arguments -> ('a * 'x, 'c) arguments + + type 'c obj_builder = State.t -> 'c + constraint 'c = #Conversion.ctx + + type _ t = Query : ('a,'x,'c) query_contents * ('a,'k,Conversion.ctx) Conversion.context * 'c obj_builder -> 'x t + and ('a,'x,'c) query_contents = { + context : 'a list; + predicate : constant; + arguments : ('x,'c) arguments; + } end @@ -1084,8 +1080,10 @@ type symbol_table = { } [@@deriving show] +type 'a query_readback = term StrMap.t -> constraints -> State.t -> 'a + type 'a executable = { - (* the lambda-Prolog program: an indexed list of clauses *) + (* the lambda-Prolog program: an indexed list of clauses *) compiled_program : prolog_prog; (* chr rules *) chr : CHR.t; @@ -1102,7 +1100,7 @@ type 'a executable = { (* solution *) assignments : term Util.StrMap.t; (* type of the query, reified *) - query_arguments: 'a Query.arguments; + query_readback : 'a query_readback; } type pp_ctx = { diff --git a/src/dune b/src/dune index 142fce86b..336b1facf 100644 --- a/src/dune +++ b/src/dune @@ -3,8 +3,6 @@ (public_name elpi) (preprocess (per_module ((action (run ppxfindcache_deriving_std %{input-file} - --cache-file %{dep:.ppcache/API.ml} - --cache-file %{dep:.ppcache/API.mli} --cache-file %{dep:.ppcache/util.ml} --cache-file %{dep:.ppcache/util.mli} --cache-file %{dep:.ppcache/ast.ml} @@ -12,7 +10,7 @@ --cache-file %{dep:.ppcache/data.ml} --cache-file %{dep:.ppcache/compiler.ml} --cache-file %{dep:.ppcache/compiler.mli})) - API ast data compiler) + ast data compiler) ((action (run ppxfindcache_elpi_trace_deriving_std %{input-file} --ppx-opt --cookie --ppx-opt "elpi_trace=\"true\"" @@ -88,7 +86,7 @@ (modules merlinppx) (libraries (select merlinppx.ml from - (ocaml-migrate-parsetree elpi.trace_ppx ppx_deriving.std -> merlinppx.ppx.ml) + (elpi.trace.ppx ppx_deriving.std -> merlinppx.ppx.ml) (-> merlinppx.noop.ml))) (flags -linkall) ) diff --git a/src/elpi-checker.elpi b/src/elpi-checker.elpi index 6aca4ec90..ef5160bda 100644 --- a/src/elpi-checker.elpi +++ b/src/elpi-checker.elpi @@ -94,6 +94,7 @@ unif A B :- (A = B ; rm-any-variadic A A1, rm-any-variadic B B1, A1 = B1), !. pred rm-any-variadic i:typ, o:typ. rm-any-variadic (tconst S as C) X :- !, if (S = "any") (X = FRESH_) (X = C). +rm-any-variadic (tconst S as C) X :- !, if (S = "nominal") (X = FRESH_) (X = C). rm-any-variadic (tapp [tconst "variadic",_,X]) X1 :- !, rm-any-variadic X X1. rm-any-variadic (tapp L) (tapp L1) :- !, rm-any-variadic-list L L1. rm-any-variadic (ctype _ as X) X. @@ -169,7 +170,7 @@ typecheck [ (clause Loc Names Clause) | Rest] Q T0 NP RC :- mode (refresh i o). refresh (forall F) T :- !, refresh (F FRESH_) T. -refresh (tconst "any") FRESH_ :- !. +refresh (tconst "nominal") FRESH_ :- !. refresh X X. safe-dest-app (app [X | A]) X A :- !. diff --git a/src/merlinppx.ppx.ml b/src/merlinppx.ppx.ml index 05a41ba86..e3cba4049 100644 --- a/src/merlinppx.ppx.ml +++ b/src/merlinppx.ppx.ml @@ -1 +1 @@ -let () = Migrate_parsetree.Driver.run_main () \ No newline at end of file +let () = Ppxlib.Driver.standalone () diff --git a/src/runtime.ml b/src/runtime.ml index 9f2a08639..bcb8e5a33 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -1862,28 +1862,6 @@ let out_of_term ~depth readback n bname state t = | Discard -> Data.BuiltInPredicate.Discard | _ -> Data.BuiltInPredicate.Keep -let in_of_term ~depth readback n bname state t = - wrap_type_err bname n (readback ~depth state) t - -let inout_of_term ~depth readback n bname state t = - wrap_type_err bname n (readback ~depth state) t - -let mk_out_assign ~depth embed bname state input v output = - match output, input with - | None, Data.BuiltInPredicate.Discard -> state, [] - | Some _, Data.BuiltInPredicate.Discard -> state, [] (* We could warn that such output was generated without being required *) - | Some t, Data.BuiltInPredicate.Keep -> - let state, t, extra = embed ~depth state t in - state, extra @ [App(Global_symbols.eqc, v, [t])] - | None, Data.BuiltInPredicate.Keep -> state, [] - -let mk_inout_assign ~depth embed bname state input v output = - match output with - | None -> state, [] - | Some t -> - let state, t, extra = embed ~depth state (Data.BuiltInPredicate.Data t) in - state, extra @ [App(Global_symbols.eqc, v, [t])] - let in_of_termC ~depth readback n bname hyps constraints state t = wrap_type_err bname n (readback ~depth hyps constraints state) t @@ -1914,9 +1892,9 @@ let map_acc f s l = in aux [] [] s l -let call (Data.BuiltInPredicate.Pred(bname,ffi,compute)) ~depth hyps constraints state data = - let rec aux : type i o h c. - (i,o,h,c) Data.BuiltInPredicate.ffi -> h -> c -> compute:i -> reduce:(State.t -> o -> State.t * extra_goals) -> +let call (Data.BuiltInPredicate.Pred(bname,ffi,in_ctx,compute)) ~depth hyps constraints state data = + let rec aux : type i o h. + (i,o,h) Data.BuiltInPredicate.ffi -> h -> constraints -> compute:i -> reduce:(State.t -> o -> State.t * extra_goals) -> term list -> int -> State.t -> extra_goals list -> State.t * extra_goals = fun ffi ctx constraints ~compute ~reduce data n state extra -> match ffi, data with @@ -1932,13 +1910,13 @@ let call (Data.BuiltInPredicate.Pred(bname,ffi,compute)) ~depth hyps constraints let state, result, gls = wrap_type_err bname 0 (compute ~depth ctx constraints) state in let state, l = reduce state result in state, List.(concat (rev extra)) @ gls @ List.rev l - | Data.BuiltInPredicate.VariadicIn(_,{ ContextualConversion.readback }, _), data -> + | Data.BuiltInPredicate.VariadicIn({ Conversion.readback }, _), data -> let state, i, gls = map_acc (in_of_termC ~depth readback n bname ctx constraints) state data in let state, rest = wrap_type_err bname 0 (compute i ~depth ctx constraints) state in let state, l = reduce state rest in state, List.(gls @ concat (rev extra) @ rev l) - | Data.BuiltInPredicate.VariadicOut(_,{ ContextualConversion.embed; readback }, _), data -> + | Data.BuiltInPredicate.VariadicOut({ Conversion.embed; readback }, _), data -> let i = List.map (out_of_term ~depth readback n bname state) data in let state, (rest, out) = wrap_type_err bname 0 (compute i ~depth ctx constraints) state in let state, l = reduce state rest in @@ -1949,7 +1927,7 @@ let call (Data.BuiltInPredicate.Pred(bname,ffi,compute)) ~depth hyps constraints state, List.(concat (rev extra) @ rev (concat ass) @ l) | None -> state, List.(concat (rev extra) @ rev l) end - | Data.BuiltInPredicate.VariadicInOut(_,{ ContextualConversion.embed; readback }, _), data -> + | Data.BuiltInPredicate.VariadicInOut({ Conversion.embed; readback }, _), data -> let state, i, gls = map_acc (inout_of_termC ~depth readback n bname ctx constraints) state data in let state, (rest, out) = wrap_type_err bname 0 (compute i ~depth ctx constraints) state in @@ -1961,99 +1939,73 @@ let call (Data.BuiltInPredicate.Pred(bname,ffi,compute)) ~depth hyps constraints state, List.(gls @ concat (rev extra) @ rev (concat ass) @ l) | None -> state, List.(gls @ concat (rev extra) @ rev l) end - | Data.BuiltInPredicate.CIn({ ContextualConversion.readback }, _, ffi), t :: rest -> + | Data.BuiltInPredicate.In({ Conversion.readback }, _, ffi), t :: rest -> let state, i, gls = in_of_termC ~depth readback n bname ctx constraints state t in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | Data.BuiltInPredicate.COut({ ContextualConversion.embed; readback }, _, ffi), t :: rest -> + | Data.BuiltInPredicate.Out({ Conversion.embed; readback }, _, ffi), t :: rest -> let i = out_of_term ~depth readback n bname state t in let reduce state (rest, out) = let state, l = reduce state rest in let state, ass = mk_out_assignC ~depth embed bname ctx constraints state i t out in state, ass @ l in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state extra - | Data.BuiltInPredicate.CInOut({ ContextualConversion.embed; readback }, _, ffi), t :: rest -> + | Data.BuiltInPredicate.InOut({ Conversion.embed; readback }, _, ffi), t :: rest -> let state, i, gls = inout_of_termC ~depth readback n bname ctx constraints state t in let reduce state (rest, out) = let state, l = reduce state rest in let state, ass = mk_inout_assignC ~depth embed bname ctx constraints state i t out in state, ass @ l in aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | Data.BuiltInPredicate.In({ Conversion.readback }, _, ffi), t :: rest -> - let state, i, gls = in_of_term ~depth readback n bname state t in - aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | Data.BuiltInPredicate.Out({ Conversion.embed; readback }, _, ffi), t :: rest -> - let i = out_of_term ~depth readback n bname state t in - let reduce state (rest, out) = - let state, l = reduce state rest in - let state, ass = mk_out_assign ~depth embed bname state i t out in - state, ass @ l in - aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state extra - | Data.BuiltInPredicate.InOut({ Conversion.embed; readback }, _, ffi), t :: rest -> - let state, i, gls = inout_of_term ~depth readback n bname state t in - let reduce state (rest, out) = - let state, l = reduce state rest in - let state, ass = mk_inout_assign ~depth embed bname state i t out in - state, ass @ l in - aux ffi ctx constraints ~compute:(compute i) ~reduce rest (n + 1) state (gls :: extra) - | _, t :: _ -> arity_err ~depth bname n (Some t) | _, [] -> arity_err ~depth bname n None - in - let rec aux_ctx : type i o h c. (i,o,h,c) Data.BuiltInPredicate.ffi -> (h,c) ContextualConversion.ctx_readback = function - | Data.BuiltInPredicate.Full(f,_) -> f - | Data.BuiltInPredicate.Read(f,_) -> f - | Data.BuiltInPredicate.VariadicIn(f,_,_) -> f - | Data.BuiltInPredicate.VariadicOut(f,_,_) -> f - | Data.BuiltInPredicate.VariadicInOut(f,_,_) -> f - | Data.BuiltInPredicate.Easy _ -> ContextualConversion.unit_ctx - | Data.BuiltInPredicate.In(_,_,rest) -> aux_ctx rest - | Data.BuiltInPredicate.Out(_,_,rest) -> aux_ctx rest - | Data.BuiltInPredicate.InOut(_,_,rest) -> aux_ctx rest - | Data.BuiltInPredicate.CIn(_,_,rest) -> aux_ctx rest - | Data.BuiltInPredicate.COut(_,_,rest) -> aux_ctx rest - | Data.BuiltInPredicate.CInOut(_,_,rest) -> aux_ctx rest in let reduce state _ = state, [] in - let state, ctx, csts, gls_ctx = aux_ctx ffi ~depth hyps constraints state in - let state, gls = aux ffi ctx csts ~compute ~reduce data 1 state [] in + let state, ctx, gls_ctx = in_ctx ~depth hyps constraints state in + let state, gls = aux ffi ctx constraints ~compute ~reduce data 1 state [] in state, gls_ctx @ gls ;; end -let rec embed_query_aux : type a. mk_Arg:(State.t -> name:string -> args:term list -> State.t * term) -> depth:int -> predicate:constant -> term list -> term list -> State.t -> a Query.arguments -> State.t * term - = fun ~mk_Arg ~depth ~predicate gls args state descr -> +let embed_query_args ctx ~mk_Arg = + let rec aux : type a. depth:int -> predicate:constant -> term list -> term list -> constraints -> State.t -> (a,'ctx) Query.arguments -> State.t * term + = fun ~depth ~predicate gls args constraints state descr -> match descr with | Data.Query.D(d,x,rest) -> - let state, x, glsx = d.Conversion.embed ~depth state x in - embed_query_aux ~mk_Arg ~depth ~predicate (gls @ glsx) (x :: args) state rest + let state, x, glsx = d.Conversion.embed ~depth ctx constraints state x in + aux ~depth ~predicate (gls @ glsx) (x :: args) constraints state rest | Data.Query.Q(d,name,rest) -> let state, x = mk_Arg state ~name ~args:[] in - embed_query_aux ~mk_Arg ~depth ~predicate gls (x :: args) state rest + aux ~depth ~predicate gls (x :: args) constraints state rest | Data.Query.N -> let args = List.rev args in state, match gls with | [] -> C.mkAppL predicate args | gls -> C.mkAppL Global_symbols.andc (gls @ [C.mkAppL predicate args]) + in + aux ;; -let embed_query ~mk_Arg ~depth state (Query.Query { predicate; arguments }) = - embed_query_aux ~mk_Arg ~depth ~predicate [] [] state arguments - -let rec query_solution_aux : type a. a Query.arguments -> term StrMap.t -> State.t -> a - = fun args assignments state -> +let rec query_solution_aux : type a. (a,'ctx) Query.arguments -> term StrMap.t -> 'ctx -> constraints -> State.t -> a + = fun args assignments ctx constraints state -> match args with | Data.Query.N -> () - | Data.Query.D(_,_,args) -> query_solution_aux args assignments state + | Data.Query.D(_,_,args) -> query_solution_aux args assignments ctx constraints state | Data.Query.Q(d,name,args) -> let x = StrMap.find name assignments in - let state, x, _gls = d.Conversion.readback ~depth:0 state x in - x, query_solution_aux args assignments state + let state, x, _gls = d.Conversion.readback ~depth:0 ctx constraints state x in + x, query_solution_aux args assignments ctx constraints state + +let output ctx arguments assignments constraints state = + query_solution_aux arguments assignments ctx constraints state -let output arguments assignments state = - query_solution_aux arguments assignments state +let embed_query ~mk_Arg ~depth hyps constraints state (Query.Query ({ Query.context; predicate; arguments },cc,builder)) = + let ctx_builder = Data.Conversion.context_builder cc builder (new Conversion.ctx hyps) in + let state, ctx_entries, ctx, gls = ctx_builder ~depth constraints context state in + embed_query_args ctx ~mk_Arg ~depth ~predicate gls [] constraints state arguments, + output ctx arguments (****************************************************************************** Indexing @@ -2999,7 +2951,7 @@ let try_fire_rule (gid[@trace]) rule (constraints as orig_constraints) = assignments = StrMap.empty; initial_depth = max_depth; initial_runtime_state = State.(init () |> end_goal_compilation StrMap.empty |> end_compilation); - query_arguments = Query.N; + query_readback = (fun _ _ _ -> ()); symbol_table = !C.table; builtins = !FFI.builtins; } in @@ -3432,12 +3384,12 @@ open Mainloop let mk_outcome search get_cs assignments = try let alts = search () in - let syn_csts, state, qargs, pp_ctx = get_cs () in + let syn_csts, state, readback_output, pp_ctx = get_cs () in let solution = { assignments; constraints = syn_csts; state; - output = output qargs assignments state; + output = readback_output assignments syn_csts state; pp_ctx = pp_ctx; } in Success solution, alts @@ -3448,7 +3400,7 @@ let mk_outcome search get_cs assignments = let execute_once ?max_steps ?delay_outside_fragment exec = auxsg := []; let { search; get } = make_runtime ?max_steps ?delay_outside_fragment exec in - fst (mk_outcome search (fun () -> get CS.Ugly.delayed, get CS.state |> State.end_execution, exec.query_arguments, { Data.uv_names = ref (get Pp.uv_names); table = get C.table }) exec.assignments) + fst (mk_outcome search (fun () -> get CS.Ugly.delayed, get CS.state |> State.end_execution, exec.query_readback, { Data.uv_names = ref (get Pp.uv_names); table = get C.table }) exec.assignments) ;; let execute_loop ?delay_outside_fragment exec ~more ~pp = @@ -3456,7 +3408,7 @@ let execute_loop ?delay_outside_fragment exec ~more ~pp = let k = ref noalts in let do_with_infos f = let time0 = Unix.gettimeofday() in - let o, alts = mk_outcome f (fun () -> get CS.Ugly.delayed, get CS.state |> State.end_execution, exec.query_arguments, { Data.uv_names = ref (get Pp.uv_names); table = get C.table }) exec.assignments in + let o, alts = mk_outcome f (fun () -> get CS.Ugly.delayed, get CS.state |> State.end_execution, exec.query_readback, { Data.uv_names = ref (get Pp.uv_names); table = get C.table }) exec.assignments in let time1 = Unix.gettimeofday() in k := alts; pp (time1 -. time0) o in diff --git a/src/runtime.mli b/src/runtime.mli index b11a020b5..a86805692 100644 --- a/src/runtime.mli +++ b/src/runtime.mli @@ -22,7 +22,8 @@ val pp_stuck_goal : ?pp_ctx:pp_ctx -> Fmt.formatter -> stuck_goal -> unit val embed_query : mk_Arg:(State.t -> name:string -> args:term list -> State.t * term) -> depth:int -> - State.t -> 'a Query.t -> State.t * term + hyps -> constraints -> + State.t -> 'a Query.t -> (State.t * term) * 'a query_readback (* Interpreter API *) val execute_once : @@ -49,11 +50,11 @@ val mkConst : constant -> term val mkAppL : constant -> term list -> term val mkAppArg : int -> int -> term list -> term -val move : +val move : adepth:int -> env -> ?avoid:uvar_body -> from:int -> to_:int -> term -> term -val hmove : +val hmove : ?avoid:uvar_body -> from:int -> to_:int -> term -> term val subst: depth:int -> term list -> term -> term