From 10d43dc33c9b0ddc2286eadb4e1a9b51eb465f13 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Apr 2020 14:01:16 +0200 Subject: [PATCH 1/7] 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/7] 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/7] 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 From a3bd387e2a42b1547103c17a2420c34d44b7a025 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 16:51:26 +0200 Subject: [PATCH 4/7] enter elpi.ppx --- ppx_elpi/dune | 15 + ppx_elpi/ppx_elpi.ml | 1360 +++++++++++++++++ ppx_elpi/tests/README.md | 17 + ppx_elpi/tests/dune | 27 + ppx_elpi/tests/dune.inc | 253 +++ ppx_elpi/tests/gen_dune.ml | 43 + ppx_elpi/tests/pp.ml | 1 + ppx_elpi/tests/test_alias_type.expected.elpi | 10 + ppx_elpi/tests/test_alias_type.expected.ml | 67 + ppx_elpi/tests/test_alias_type.ml | 18 + .../test_double_contextual.expected.elpi | 37 + .../tests/test_double_contextual.expected.ml | 953 ++++++++++++ ppx_elpi/tests/test_double_contextual.ml | 45 + ppx_elpi/tests/test_mutual_adt.expected.elpi | 27 + ppx_elpi/tests/test_mutual_adt.expected.ml | 232 +++ ppx_elpi/tests/test_mutual_adt.ml | 20 + ppx_elpi/tests/test_opaque_type.expected.elpi | 8 + ppx_elpi/tests/test_opaque_type.expected.ml | 43 + ppx_elpi/tests/test_opaque_type.ml | 22 + ppx_elpi/tests/test_poly_adt.expected.elpi | 18 + ppx_elpi/tests/test_poly_adt.expected.ml | 189 +++ ppx_elpi/tests/test_poly_adt.ml | 21 + ppx_elpi/tests/test_poly_alias.expected.elpi | 10 + ppx_elpi/tests/test_poly_alias.expected.ml | 98 ++ ppx_elpi/tests/test_poly_alias.ml | 18 + ppx_elpi/tests/test_ppx.mli | 0 ppx_elpi/tests/test_simple_adt.expected.elpi | 16 + ppx_elpi/tests/test_simple_adt.expected.ml | 118 ++ ppx_elpi/tests/test_simple_adt.ml | 18 + .../test_simple_adt_record.expected.elpi | 16 + .../tests/test_simple_adt_record.expected.ml | 150 ++ ppx_elpi/tests/test_simple_adt_record.ml | 18 + .../test_simple_contextual.expected.elpi | 21 + .../tests/test_simple_contextual.expected.ml | 475 ++++++ ppx_elpi/tests/test_simple_contextual.ml | 31 + .../tests/test_simple_record.expected.elpi | 14 + ppx_elpi/tests/test_simple_record.expected.ml | 115 ++ ppx_elpi/tests/test_simple_record.ml | 18 + .../test_two_layers_context.expected.elpi | 5 + .../tests/test_two_layers_context.expected.ml | 1209 +++++++++++++++ ppx_elpi/tests/test_two_layers_context.ml | 103 ++ src/builtin.ml | 26 + src/builtin.mli | 24 + src/builtin_ppx.elpi | 23 + src/dune | 9 +- 45 files changed, 5959 insertions(+), 2 deletions(-) create mode 100644 ppx_elpi/dune create mode 100644 ppx_elpi/ppx_elpi.ml create mode 100644 ppx_elpi/tests/README.md create mode 100644 ppx_elpi/tests/dune create mode 100644 ppx_elpi/tests/dune.inc create mode 100644 ppx_elpi/tests/gen_dune.ml create mode 100644 ppx_elpi/tests/pp.ml create mode 100644 ppx_elpi/tests/test_alias_type.expected.elpi create mode 100644 ppx_elpi/tests/test_alias_type.expected.ml create mode 100644 ppx_elpi/tests/test_alias_type.ml create mode 100644 ppx_elpi/tests/test_double_contextual.expected.elpi create mode 100644 ppx_elpi/tests/test_double_contextual.expected.ml create mode 100644 ppx_elpi/tests/test_double_contextual.ml create mode 100644 ppx_elpi/tests/test_mutual_adt.expected.elpi create mode 100644 ppx_elpi/tests/test_mutual_adt.expected.ml create mode 100644 ppx_elpi/tests/test_mutual_adt.ml create mode 100644 ppx_elpi/tests/test_opaque_type.expected.elpi create mode 100644 ppx_elpi/tests/test_opaque_type.expected.ml create mode 100644 ppx_elpi/tests/test_opaque_type.ml create mode 100644 ppx_elpi/tests/test_poly_adt.expected.elpi create mode 100644 ppx_elpi/tests/test_poly_adt.expected.ml create mode 100644 ppx_elpi/tests/test_poly_adt.ml create mode 100644 ppx_elpi/tests/test_poly_alias.expected.elpi create mode 100644 ppx_elpi/tests/test_poly_alias.expected.ml create mode 100644 ppx_elpi/tests/test_poly_alias.ml create mode 100644 ppx_elpi/tests/test_ppx.mli create mode 100644 ppx_elpi/tests/test_simple_adt.expected.elpi create mode 100644 ppx_elpi/tests/test_simple_adt.expected.ml create mode 100644 ppx_elpi/tests/test_simple_adt.ml create mode 100644 ppx_elpi/tests/test_simple_adt_record.expected.elpi create mode 100644 ppx_elpi/tests/test_simple_adt_record.expected.ml create mode 100644 ppx_elpi/tests/test_simple_adt_record.ml create mode 100644 ppx_elpi/tests/test_simple_contextual.expected.elpi create mode 100644 ppx_elpi/tests/test_simple_contextual.expected.ml create mode 100644 ppx_elpi/tests/test_simple_contextual.ml create mode 100644 ppx_elpi/tests/test_simple_record.expected.elpi create mode 100644 ppx_elpi/tests/test_simple_record.expected.ml create mode 100644 ppx_elpi/tests/test_simple_record.ml create mode 100644 ppx_elpi/tests/test_two_layers_context.expected.elpi create mode 100644 ppx_elpi/tests/test_two_layers_context.expected.ml create mode 100644 ppx_elpi/tests/test_two_layers_context.ml create mode 100644 src/builtin_ppx.elpi diff --git a/ppx_elpi/dune b/ppx_elpi/dune new file mode 100644 index 000000000..034b6549f --- /dev/null +++ b/ppx_elpi/dune @@ -0,0 +1,15 @@ +(library + (name ppx_elpi) + (public_name elpi.ppx) + (synopsis "[@@elpi]") + (libraries re ppxlib) + (preprocess (pps ppxlib.metaquot)) + (ppx_runtime_libraries elpi) + (modules ppx_elpi) + (kind ppx_rewriter) + (optional) +) + +(env + (dev + (flags (:standard -warn-error -A)))) \ No newline at end of file diff --git a/ppx_elpi/ppx_elpi.ml b/ppx_elpi/ppx_elpi.ml new file mode 100644 index 000000000..346bb36b9 --- /dev/null +++ b/ppx_elpi/ppx_elpi.ml @@ -0,0 +1,1360 @@ +open Ppxlib +open Ppxlib.Ast_pattern + +(** + + Deriving directives: + + [@@deriving elpi] Simple ADT. + [@@deriving elpi { index = (module M) }] Context ADT. + M is an OrderedType and Show, it is used to instantiate the + functor Elpi.Utils.Map.Make. + All constructors must have 1 argument with attribute [@elpi.key] + and that argument must be of type M.t + [@@deriving elpi { context = (() : ty) }] HOADT. + Its context is represented by items of the context ADT ty, if ty is a + type name. + If ty is of the form "(ty1 -> ctx1) * .. * (tyn -> ctxn)" then the + context is represented by items of (the union of) the context ADTs + ctx1 ... ctxn. ": ty" stands for ": (current_type -> ty)". + Constructors can have the [@elpi.var] attribute and + constructor arguments can have the [@elpi.binder] attribute + [@@deriving elpi { append = l }] + appends to list (l : Elpi.API.BuiltIn.declaration list ref) + all data types that were derived + + In all cases the type must come with a pretty printer named following the + ppx_deriving.show convention (named pp if the type is named t, pp_ty + otherwise). Using both [@@derving show, elpi] on each data type is + the simplest option. + +*) +let pexp_ignore = Deriving.Args.of_func (fun _ _ (_e : expression) b -> b) + +let arguments = Deriving.Args.(empty + +> arg "index" (pexp_pack __) + +> arg "context" (pexp_constraint pexp_ignore __) + +> arg "append" __ +) +(** + Type attributes: + + [@@elpi.code] + see the constructor attribute with the same name + [@@elpi.doc] + see the constructor attribute with the same name + [@@elpi.default_readback] + the default case can be used to read back flexible terms. The default is + a runtime type error + [@@elpi.pp] + code for pretty printing the data. Type is the one ppx_deriving.show + would produce +*) +let att_elpi_tcode = Attribute.(declare "elpi.code" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_tdoc = Attribute.(declare "elpi.doc" Context.type_declaration (single_expr_payload (estring __)) (fun x -> x)) +let att_elpi_treadback = Attribute.(declare "elpi.default_readback" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_pp = Attribute.(declare "elpi.pp" Context.type_declaration (single_expr_payload __) (fun x -> x)) +(** + Constructor attributes: + + [@elpi.var] An Elpi bound variable. + Optional argument is a function from the constructor arguments to the + type being the [@elpi.key] for the context. + [@elpi.skip] Not exposed to Elpi. + [@elpi.embed] Custom embedding code. + Argument of type Elpi.API.ContextualConversion.embedding + [@elpi.readback] Custom readback code. + Argument of type Elpi.API.ContextualConversion.embedding + [@elpi.code] Custom Elpi declaration. + First argument is a string and stands for the name of the type + constructor. The default is the name of the OCaml constructor in lowercase + where _ is replaced by - . Eg Foo_BAR becomes foo-bar. + Second argument is optional and is a string used as the Elpi type + for the constructor. Default is derived from the types of the fields. + [@elpi.doc] Custom documentation. + Argument is a string. Default doc is the name of the OCaml constructor +*) +let att_elpi_var = Attribute.(declare "elpi.var" Context.constructor_declaration (alt_option (single_expr_payload __) (pstr nil)) (fun x -> x)) +let att_elpi_skip = Attribute.(declare "elpi.skip" Context.constructor_declaration (pstr nil) ()) +let att_elpi_embed = Attribute.(declare "elpi.embed" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_readback = Attribute.(declare "elpi.readback" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_code = Attribute.(declare "elpi.code" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_doc = Attribute.(declare "elpi.doc" Context.constructor_declaration (single_expr_payload (estring __)) (fun x -> x)) +(** + + Constructor field attribute: + + [@elpi.key] Field used as a key in the Map to values of this type. + [@elpi.binder] Field is below one binder. + First argument is optional and is a string (or an ident) and is the type + of the bound variable. Default value is the type to which [@@elpi : ty] + is applied. + Second argument is a function taking all other fields and returning + a ctx entry (a value in the type ty of [@@elpi : ty]) +*) +let att_elpi_key = Attribute.(declare "elpi.key" Context.core_type (pstr nil) ()) +let att_elpi_binder = Attribute.(declare "elpi.binder" Context.core_type (single_expr_payload __) (fun x -> x)) +(** + Extensions: + + [%elpi : ty] the conversion of type ty + + Conventions: + + is a value of type Elpi.API.ContextualConversion.t for type ty. + + in_ is a value of type Elpi.API.ContextualConversion.ctx_readback + for type . It exists only for context ADTs. + + Elpi__Map is a module of signature Elpi.API.Utils.Map.S built using + Elpi.API.Utils.Map.Make(M) where type ctx is a context ADT annotated as + [@@elpi (module M)]. It exists only for context ADTs. + + TODO: elpi_push_xxx elpi_pop_xxx elpi_xxx_state elpi_xxx_to_key elpi_xxx + + Internal conventions: + + Variables are named elpi__something so that they don't collide with + any variable named elpi_something or something. + + *) + let elpi_name_mangle txt = + String.map (function '_' -> '-' | x -> x) @@ + String.lowercase_ascii txt +let elpi_map_name x = "Elpi_"^x^"_Map" +let elpi_state_name x = "elpi_"^x^"_state" +let elpi_in_name_alone x = "in_" ^ x ^ "_alone" +let elpi_in_name x = "in_" ^ x +let elpi_to_key x = "elpi_" ^ x ^ "_to_key" +let elpi_is_ctx_entry_name x = "elpi_is_" ^ x +let elpi_embed_name x = "elpi_embed_" ^ x +let elpi_readback_name x = "elpi_readback_" ^ x +let elpi_push x = "elpi_push_" ^ x +let elpi_pop x = "elpi_pop_" ^ x +let elpi_kname t k = "elpi_constant_constructor_" ^ t ^ "_" ^ k ^ "c" +let elpi_tname t = "elpi_constant_type_" ^ t ^ "c" +let elpi_kname_str t k = "elpi_constant_constructor_" ^ t ^ "_" ^ k +let elpi_tname_str t = "elpi_constant_type_" ^ t +let param_prefix = "elpi__param__" +let fresh = + let x = ref 0 in + fun () -> incr x; Printf.sprintf "elpi__%d" !x +let elpi_Map ~loc x f = Ast_builder.Default.evar ~loc ("Elpi_"^x^"_Map." ^ f) + + +let is_some = function Some _ -> true | _ -> false +let option_get = function Some x -> x | _ -> assert false +let option_map f = function Some x -> Some (f x) | _ -> None +let option_default d = function Some x -> x | _ -> d +let rec filter_map f = function + | [] -> [] + | x :: xs -> + match f x with + | None -> filter_map f xs + | Some y -> y :: filter_map f xs + +let error ?loc = Location.raise_errorf ?loc +let nYI ~loc ~__LOC__ () = error ~loc "nYI: %s" __LOC__ + +let elpi_loc_of_position (module B : Ast_builder.S) pos = let open B in + let open Location in + let open Lexing in + [%expr { + Elpi.API.Ast.Loc.source_name = [%e estring @@ pos.pos_fname ]; + source_start = [%e eint @@ pos.pos_cnum ]; + source_stop = [%e eint @@ pos.pos_cnum ]; + line = [%e eint @@ pos.pos_lnum ]; + line_starts_at = [%e eint @@ pos.pos_bol ]; + }] + +(* +let get_attr_expr s l = + match find_attr_expr s l with + | None -> error ("attribute " ^ s ^ " with no payload") + | Some e -> e +*) + + + +let pexp_disable_warnings (module B : Ast_builder.S) x = + [%expr [%e x ][@warning "-26-27-32-39-60"]] + +let abstract_expr_over_params (module B : Ast_builder.S) vl f e = let open B in + let rec aux = function + | [] -> e + | v :: vs -> [%expr fun [%p pvar (f v) ] -> [%e aux vs]] + in + aux vl + +let rec on_last f = function + | [] -> assert false + | [x] -> [f x] + | y :: ys -> y :: on_last f ys + +type directive = + | Standard + | Custom of expression * position + | Name of expression +let is_name = function Name _ -> true | _ -> false + +type arg_type = + | FO of { + argFO_key : bool; + argFO_readback : expression; + argFO_embed : expression; + argFO_ty_ast : expression; + argFO_ty : core_type; + } + | HO of { + argHO_arrow_src : string; + argHO_build_ctx : expression; + argHO_readback : expression; + argHO_embed : expression; (* if context = SOMe map, then store here which component of the state one has to pick *) + argHO_ty_ast : expression; + argHO_ty : core_type; + } +let is_key = function FO { argFO_key = k; _ } -> k | _ -> false +let is_HO = function HO _ -> true | _ -> false + +let ctx_index_ty (module B : Ast_builder.S) = let open B in + FO { + argFO_readback = [%expr Elpi.API.PPX.readback_nominal ]; + argFO_embed = [%expr Elpi.API.PPX.embed_nominal ]; + argFO_ty_ast = [%expr Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty ]; + argFO_ty = [%type: int]; + argFO_key = false; + } + +type elpi_constructor = + | Skip of { constructor_name : string; has_args : bool } + | Expose of expose +and expose = { + declaration : structure_item list; + constant : expression; + constant_name : string; + constructor : expression list -> expression; + pattern : pattern list -> pattern; + types : arg_type list; + embed : directive; + readback : directive; + elpi_code : expression option; (* string *) + elpi_doc : string; + } + +type elpi_type_decl = + | Opaque + | Alias of core_type + | Algebraic of elpi_constructor list * expression option (* default readback *) + +type elpi_type = { + name : string; + elpi_name : string; + elpi_code : string option; + elpi_doc : string; + params : string list; + type_decl : elpi_type_decl; + pp : expression option; + } + +type task_kind = ADT | CTX of module_expr * string list | HOAS of (string * string) list +type task = elpi_type * task_kind + +type type_extras = { + ty_constants : structure_item list; + ty_embed : value_binding; + ty_readback : value_binding; + ty_conversion : value_binding; + ty_conversion_name : string; + ty_context_helpers : structure_item list; + ty_context_readback : structure_item list; + ty_elpi_declaration : elpi_declaration; + ty_opaque : bool; + ty_library : expression option; (* should be Elpi AST *) +} +and elpi_declaration = { + decl : structure_item; + decl_name : expression +} + +let ctx_for k = function + | None -> assert false + | Some l -> + try List.assoc k l + with Not_found -> + error "cannot find context type for %s" k + +let rec drop_skip = function + | [] -> [] + | Skip _ :: l -> drop_skip l + | Expose x :: l -> x :: drop_skip l +let rec keep_skip = function + | [] -> [] + | Skip { constructor_name; has_args } :: l -> (constructor_name, has_args) :: keep_skip l + | Expose _ :: l -> keep_skip l + +let rec list_take i = function + | [] -> [] + | _ :: _ when i = 0 -> [] + | x :: xs -> x :: list_take (i-1) xs + +let rec embed_k (module B : Ast_builder.S) ctx c all_kargs all_tmp kargs tmp tys n = let open B in + match kargs, tmp, tys with + | [], [], [] -> + [%expr elpi__state, Elpi.API.RawData.mkAppL [%e c] [%e elist @@ List.map evar @@ List.map fst all_kargs], List.concat [%e elist all_tmp] ] + | (px,ex) :: xs, y :: ys, (FO { argFO_embed = t; _ }) :: ts -> [%expr + let elpi__state, [%p pvar px], [%p pvar y] = + [%e t] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state [%e ex] in + [%e embed_k (module B) ctx c all_kargs all_tmp xs ys ts (n+1)]] + | (px,ex) :: xs, y :: ys, HO{ argHO_build_ctx = f; argHO_embed = t; argHO_arrow_src = src; _ } :: ts -> + let xtmp = fresh () in + let ctx_name = ctx_for src ctx in + let elpi_to_key = evar (elpi_to_key ctx_name) in + let elpi_push = evar (elpi_push ctx_name) in + let elpi_pop = evar (elpi_pop ctx_name) in + [%expr + let elpi__ctx_entry = [%e eapply f (List.map snd @@ list_take n all_kargs) ] in + let elpi__ctx_key = [%e elpi_to_key ] ~depth: elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = { Elpi.API.ContextualConversion.entry = elpi__ctx_entry; depth = elpi__depth } in + let elpi__state = [%e elpi_push ] ~depth: (elpi__depth + 1) elpi__state elpi__ctx_key elpi__ctx_entry in + let elpi__state, [%p pvar xtmp], [%p pvar y] = + [%e t] ~depth: (elpi__depth + 1) elpi__hyps elpi__constraints elpi__state [%e ex] in + let [%p pvar px] = Elpi.API.RawData.mkLam [%e evar xtmp] in + let elpi__state = [%e elpi_pop ] ~depth: (elpi__depth + 1) elpi__state elpi__ctx_key in + [%e embed_k (module B) ctx c all_kargs all_tmp xs ys ts (n+1)]] + | _ -> assert false +;; + +let embed_var (module B : Ast_builder.S) ctx_name args p = let open B in + let elpi_Map = elpi_Map ~loc ctx_name in + [%expr + let elpi__ctx2dbl, _ = Elpi.API.State.get [%e evar (elpi_state_name ctx_name)] elpi__state in + let elpi__key = [%e eapply p args] in + if not ([%e elpi_Map "mem" ] elpi__key elpi__ctx2dbl) then + Elpi.API.Utils.error "Unbound variable"; + elpi__state, Elpi.API.RawData.mkBound ([%e elpi_Map "find" ] elpi__key elpi__ctx2dbl), [] + ] + +let error_constructor_not_supported (module B : Ast_builder.S) (constructor,has_args) = let open B in + case ~guard:None ~lhs:(ppat_construct (Located.lident constructor) (if has_args then Some (pvar "_") else None)) + ~rhs:[%expr Elpi.API.Utils.error ("constructor "^[%e estring constructor]^" is not supported") ] + +let abstract_standard_branch_embed (module B : Ast_builder.S) l e = let open B in + let rec aux = function + | [] -> e + | x::xs -> [%expr fun [%p pvar x] -> [%e aux xs]] + in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> [%e aux l ]] + +let embed_branch (module B : Ast_builder.S) name (is_pred,ctx) = function + | Skip { constructor_name; has_args } -> error_constructor_not_supported (module B) (constructor_name,has_args) + | Expose { constant; types; embed; pattern; _ } -> let open B in + let pvl, pattern, types = + let pvl = List.map (fun _ -> fresh()) types in + let kpattern = pattern (List.map pvar pvl) in + if is_pred then + let idx = fresh () in + idx :: pvl, ppat_tuple [pvar idx;kpattern], ctx_index_ty (module B) :: types + else pvl, kpattern, types in + let standard = + let evl = List.map (fun _ -> fresh()) types in + let pvl2 = List.map (fun x -> fresh (), evar x) pvl in + embed_k (module B) ctx constant pvl2 (List.map evar evl) pvl2 evl types 0 in + case ~guard:None ~lhs:pattern + ~rhs:begin match embed with + | Custom (e,_) -> + eapply [%expr [%e e] [%e abstract_standard_branch_embed (module B) pvl standard ] + ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state] (List.map evar pvl) + | Standard -> standard + | Name p -> + let ctx_name = ctx_for name ctx in + embed_var (module B) ctx_name (List.map evar pvl) p + end + +let embed (module B : Ast_builder.S) name job kl = let open B in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> + [%e pexp_function (List.map (embed_branch (module B) name job) kl) ]] + +let readback_k (module B : Ast_builder.S) c ctx mk_k t ts = let open B in + let one all_kargs n p1 e1 t x kont = + match t with + | FO { argFO_readback = t; _ } -> [%expr + let elpi__state, [%p pvar p1], [%p pvar e1] = + [%e t] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state [%e x] in + [%e kont] ] + | HO { argHO_build_ctx = f; argHO_readback = t; argHO_arrow_src = src; _ } -> + let ctx_name = ctx_for src ctx in + let elpi_to_key = evar (elpi_to_key ctx_name) in + let elpi_push = evar (elpi_push ctx_name) in + let elpi_pop = evar (elpi_pop ctx_name) in + [%expr + let elpi__ctx_entry = [%e eapply f (List.map evar @@ list_take n all_kargs) ] in + let elpi__ctx_key = [%e elpi_to_key ] ~depth: elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = { Elpi.API.ContextualConversion.entry = elpi__ctx_entry; depth = elpi__depth } in + let elpi__state = [%e elpi_push ] ~depth: elpi__depth elpi__state elpi__ctx_key elpi__ctx_entry in + let elpi__state, [%p pvar p1], [%p pvar e1] = + match Elpi.API.RawData.look ~depth: elpi__depth [%e x] with + | Elpi.API.RawData.Lam elpi__bo -> + [%e t] ~depth: (elpi__depth + 1) elpi__hyps elpi__constraints elpi__state elpi__bo + | _ -> assert false in + let elpi__state = [%e elpi_pop ] ~depth: elpi__depth elpi__state elpi__ctx_key in + [%e kont]] in + let rec roll_readback all_kargs n all_tmp kargs tmp tys = + match kargs, tmp, tys with + | [], [], [] -> + [%expr (elpi__state, [%e mk_k (List.map evar all_kargs)], List.concat [%e elist @@ List.map evar all_tmp]) ] + | x :: xs, y :: ys, t :: ts -> + one all_kargs n x y t (evar x) (roll_readback all_kargs (n+1) all_tmp xs ys ts) + | _ -> assert false + in + let rec roll_pat = function + | [] -> [%pat? [] ] + | x :: xs -> [%pat? [%p pvar x] :: [%p roll_pat xs] ] in + let ps = List.map (fun _ -> fresh()) ts in + let es = List.map (fun _ -> fresh()) ts in + let p1, e1 = fresh (), fresh () in + let all_kargs = p1 :: ps in + one all_kargs 0 p1 e1 t [%expr elpi__x] [%expr + match elpi__xs with + | [%p roll_pat ps ] -> + [%e roll_readback all_kargs 1 (e1 :: es) ps es ts] + | _ -> Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ Elpi.API.RawData.Constants.show [%e c]) + ] + +let readback_var (module B : Ast_builder.S) ctx_name constructor = let open B in + let elpi_to_key = evar (elpi_to_key ctx_name) in + let elpi_state_component = evar (elpi_state_name ctx_name) in + [%expr + let _, elpi__dbl2ctx = Elpi.API.State.get [%e elpi_state_component ] elpi__state in + if not (Elpi.API.RawData.Constants.Map.mem elpi__hd elpi__dbl2ctx) then + Elpi.API.Utils.error (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp (Elpi.API.ContextualConversion.pp_ctx_entry [%e evar ("pp_" ^ ctx_name)])) elpi__dbl2ctx); + let { Elpi.API.ContextualConversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd elpi__dbl2ctx in + elpi__state, [%e constructor [ [%expr [%e elpi_to_key ] ~depth: elpi__depth elpi__entry ] ] ], [] + ] + +let abstract_standard_branch_readback (module B : Ast_builder.S) pos e = let open B in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> function + | [] -> [%e e ] + | _ -> Elpi.API.Utils.error ~loc: [%e elpi_loc_of_position (module B) pos ] "standard branch readback takes 0 arguments"] + +let abstract_standard_branch_readback2 (module B : Ast_builder.S) pos e = let open B in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> function + | elpi__x :: elpi__xs -> [%e e ] + | [] -> Elpi.API.Utils.error ~loc: [%e elpi_loc_of_position (module B) pos ] "standard branch readback takes 1 argument or more"] + +let readback_branch (module B : Ast_builder.S) name (is_pred,ctx) { constant; constructor; types; readback; _ } = let open B in + let types, mk_k = + if is_pred then ctx_index_ty (module B) :: types, (function x :: xs -> pexp_tuple [x;constructor xs] | [] -> assert false) + else types, constructor in + match types with + | [] -> + let standard = [%expr elpi__state, [%e constructor [] ], []] in + case ~lhs:[%pat? Elpi.API.RawData.Const elpi__hd] + ~guard:(Some [%expr elpi__hd == [%e constant]]) + ~rhs:begin match readback with + | Standard -> standard + | Custom(e,pos) -> [%expr [%e e] [%e abstract_standard_branch_readback (module B) pos standard] ~depth: elpi__depth elpi__hyps elpi__constraints [] ] + | Name _ -> assert false + end + | t :: ts -> + let standard = readback_k (module B) constant ctx mk_k t ts in + match readback with + | Standard -> + case ~lhs:[%pat? Elpi.API.RawData.App (elpi__hd,elpi__x,elpi__xs)] + ~guard:(Some [%expr elpi__hd == [%e constant]]) + ~rhs:standard + | Custom(e,pos) -> + case ~lhs:[%pat? Elpi.API.RawData.App (elpi__hd,elpi__x,elpi__xs)] + ~guard:(Some [%expr elpi__hd == [%e constant]]) + ~rhs:([%expr [%e e] [%e abstract_standard_branch_readback2 (module B) pos standard ] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state (elpi__x :: elpi__xs)]) + | Name _ -> assert(ts = []); + let ctx_name = ctx_for name ctx in + case ~lhs:[%pat? Elpi.API.RawData.Const elpi__hd] + ~guard:(Some [%expr elpi__hd >= 0]) + ~rhs:(readback_var (module B) ctx_name constructor) + +let abstract_standard_default_readback (module B : Ast_builder.S) e = let open B in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state elpi__x -> [%e e]] + +let readback (module B : Ast_builder.S) name job default_readback kl = let open B in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state elpi__x -> + [%e pexp_match [%expr Elpi.API.RawData.look ~depth: elpi__depth elpi__x] + (List.map (readback_branch (module B) name job) (drop_skip kl) @ + [case ~guard:None ~lhs:[%pat? _ ] + ~rhs:begin + let standard = + [%expr Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" + [%e estring name] (Elpi.API.RawPp.term elpi__depth) elpi__x) ] in + match default_readback with + | None -> standard + | Some e -> [%expr [%e e] [%e abstract_standard_default_readback (module B) standard ] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state elpi__x ] + end])]] + +let ctx_entry_key (module B : Ast_builder.S) kl = let open B in + let project { pattern; types; _ } = + let pvl = List.map (function FO { argFO_key = true; _ } -> fresh() | _ -> "_") types in + let rec find_key vl tl = + match vl, tl with + | v :: _, FO { argFO_key = true; _ } :: _ -> evar v + | _ :: vs, _ :: ts -> find_key vs ts + | _ -> assert false in + + case ~lhs:(pattern (List.map pvar pvl)) ~guard:None ~rhs:(find_key pvl types) in + [%expr fun ~depth:_ -> [%e pexp_function ( + List.map project (drop_skip kl) @ + List.map (error_constructor_not_supported (module B)) (keep_skip kl)) ] ] + +let is_ctx_entry (module B : Ast_builder.S) kl = let open B in + [%expr fun ~depth: elpi__depth elpi__x -> match Elpi.API.RawData.look ~depth: elpi__depth elpi__x with + | Elpi.API.RawData.Const _ -> None + | Elpi.API.RawData.App(elpi__hd,elpi__idx,_) -> + if [%e + List.fold_left (fun e -> function + | Skip _ -> e + | Expose { constant; _ } -> + [%expr [%e e] || elpi__hd == [%e constant]]) + [%expr false] kl + ] + then match Elpi.API.RawData.look ~depth: elpi__depth elpi__idx with + | Elpi.API.RawData.Const x -> Some x + | _ -> Elpi.API.Utils.type_error "context entry applied to a non nominal" + else None + | _ -> None ] + +let ctx_readback (module B : Ast_builder.S) name = let open B in + let elpi_Map = elpi_Map ~loc name in + let elpi_push = evar (elpi_push name) in + let elpi_to_key = evar (elpi_to_key name) in + let elpi_is_ctx_entry = evar (elpi_is_ctx_entry_name name) in + let elpi_state_component = evar (elpi_state_name name) in + [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> + let module CMap = Elpi.API.RawData.Constants.Map in + let elpi__filtered_hyps = + List.fold_left (fun elpi__m ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as elpi__hyp) -> + match [%e elpi_is_ctx_entry ] ~depth:elpi__i elpi__hsrc with + | None -> elpi__m + | Some elpi__idx -> + if CMap.mem elpi__idx elpi__m then + Elpi.API.Utils.type_error "more than one context entry for the same nominal"; + CMap.add elpi__idx elpi__hyp elpi__m + ) CMap.empty (Elpi.API.RawData.of_hyps elpi__hyps) in + let rec elpi__aux elpi__state elpi__gls elpi__i = + if elpi__i = elpi__depth then + elpi__state, List.concat (List.rev elpi__gls) + else if not (CMap.mem elpi__i elpi__filtered_hyps) then + elpi__aux elpi__state elpi__gls (elpi__i+1) + else + let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in + let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in + let elpi__state, (elpi__nominal, elpi__t), elpi__gls_t = + [%e evar name].Elpi.API.ContextualConversion.readback ~depth: elpi__hyp_depth elpi__hyps elpi__constraints elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + assert(elpi__nominal = elpi__i); + let elpi__s = [%e elpi_to_key ] ~depth: elpi__hyp_depth elpi__t in + let elpi__state = [%e elpi_push ] ~depth:elpi__i elpi__state elpi__s { Elpi.API.ContextualConversion.entry = elpi__t; depth = elpi__hyp_depth } in + elpi__aux elpi__state (elpi__gls_t :: elpi__gls) (elpi__i+1) in + let elpi__state = Elpi.API.State.set [%e elpi_state_component ] elpi__state + ([%e elpi_Map "empty" ], CMap.empty) in + let elpi__state, elpi__gls = elpi__aux elpi__state [] 0 in + let _, elpi__dbl2ctx = Elpi.API.State.get [%e elpi_state_component ] elpi__state in + elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls] + +let rec compose_ctx_readback (module B : Ast_builder.S) = function + | [] -> assert false + | [x] -> B.evar (elpi_in_name_alone x) + | x :: xs -> let open B in + [%expr Elpi.API.ContextualConversion.(|+|) + [%e evar (elpi_in_name_alone x) ] + [%e compose_ctx_readback (module B) xs] ] + +let ctx_push (module B : Ast_builder.S) name = let open B in + let elpi_Map = elpi_Map ~loc name in + [%expr fun ~depth:elpi__depth elpi__state elpi__name elpi__ctx_item -> + let elpi__ctx2dbl, elpi__dbl2ctx = Elpi.API.State.get [%e evar (elpi_state_name name)] elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = [%e elpi_Map "add" ] elpi__name elpi__i elpi__ctx2dbl in + let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item elpi__dbl2ctx in + let elpi__state = Elpi.API.State.set [%e evar (elpi_state_name name)] elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state] + +let ctx_pop (module B : Ast_builder.S) name = let open B in + let elpi_Map = elpi_Map ~loc name in + [%expr fun ~depth:elpi__depth elpi__state elpi__name -> + let elpi__ctx2dbl, elpi__dbl2ctx = Elpi.API.State.get [%e evar (elpi_state_name name)] elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = [%e elpi_Map "remove" ] elpi__name elpi__ctx2dbl in + let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in + let elpi__state = Elpi.API.State.set [%e evar (elpi_state_name name)] elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state] + +let rec fmap f = function [] -> [] | x :: xs -> match f x with None -> fmap f xs | Some x -> x :: fmap f xs + +let conversion_of (module B : Ast_builder.S) ty = let open B in + let rec aux = function + | [%type: string] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.string] + | [%type: int] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.int] + | [%type: float] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.float] + | [%type: bool] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool] + | [%type: char] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.Builtin.char] + | [%type: [%t? typ] list] -> [%expr Elpi.API.ContextualConversion.(!>>) Elpi.API.BuiltInData.list [%e aux typ ]] + | [%type: [%t? typ] option] -> [%expr Elpi.API.ContextualConversion.(!>>) Elpi.Builtin.option [%e aux typ ]] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.API.ContextualConversion.(!>>>) Elpi.Builtin.pair [%e aux typ1 ] [%e aux typ2 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.Builtin.triple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.Builtin.quadruple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.Builtin.quintuple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ] [%e aux typ5 ]] + | { ptyp_desc = Ptyp_tuple _; _ } -> error ~loc "seriously? I don't have sixtuples at hand, file a bugreport" + | { ptyp_desc = Ptyp_constr ({ txt = id; _ }, params); _ } -> + let id = pexp_ident @@ Located.mk id in + eapply id (List.map aux params) + | t -> error ~loc "cannot compute conversion for type %a" Pprintast.core_type t + in + aux ty + +let is_parameter id = Re.(Str.string_match (Str.regexp_string param_prefix) id 0) + +let rec find_embed_of (module B : Ast_builder.S) current_mutrec_block ty = let open B in + let rec aux ty = + match ty with + | [%type: string] -> [%expr Elpi.API.PPX.embed_string] + | [%type: int] -> [%expr Elpi.API.PPX.embed_int] + | [%type: float] -> [%expr Elpi.API.PPX.embed_float] + | [%type: bool] -> [%expr Elpi.Builtin.PPX.embed_bool] + | [%type: char] -> [%expr Elpi.Builtin.PPX.embed_char] + | [%type: [%t? typ] list] -> [%expr Elpi.API.PPX.embed_list [%e aux typ ]] + | [%type: [%t? typ] option] -> [%expr Elpi.Builtin.PPX.embed_option [%e aux typ ]] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.Builtin.PPX.embed_pair [%e aux typ1 ] [%e aux typ2 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.Builtin.PPX.embed_triple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.Builtin.PPX.embed_quadruple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.Builtin.PPX.embed_quintuple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ] [%e aux typ5 ]] + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, params); _ } + when List.mem id current_mutrec_block || is_parameter id -> + eapply (evar (elpi_embed_name id)) (List.map (find_embed_of (module B) current_mutrec_block) params) + | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.ContextualConversion.embed ] + in + aux ty + +let rec find_readback_of (module B : Ast_builder.S) current_mutrec_block ty = let open B in + let rec aux ty = + match ty with + | [%type: string] -> [%expr Elpi.API.PPX.readback_string] + | [%type: int] -> [%expr Elpi.API.PPX.readback_int] + | [%type: float] -> [%expr Elpi.API.PPX.readback_float] + | [%type: bool] -> [%expr Elpi.Builtin.PPX.readback_bool] + | [%type: char] -> [%expr Elpi.Builtin.PPX.readback_char] + | [%type: [%t? typ] list] -> [%expr Elpi.API.PPX.readback_list [%e aux typ ]] + | [%type: [%t? typ] option] -> [%expr Elpi.Builtin.PPX.readback_option [%e aux typ ]] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.Builtin.PPX.readback_pair [%e aux typ1 ] [%e aux typ2 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.Builtin.PPX.readback_triple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.Builtin.PPX.readback_quadruple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ]] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.Builtin.PPX.readback_quintuple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ] [%e aux typ5 ]] + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, params); _ } + when List.mem id current_mutrec_block || is_parameter id -> + eapply (evar (elpi_readback_name id)) (List.map (find_readback_of (module B) current_mutrec_block) params) + | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.ContextualConversion.readback ] + in + aux ty + +let rec find_ty_ast_of (module B : Ast_builder.S) current_mutrec_block ty = let open B in + match ty with + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, []); _ } + when List.mem id current_mutrec_block -> + [%expr Elpi.API.ContextualConversion.TyName([%e evar @@ elpi_tname_str id])] + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, p::ps); _ } + when List.mem id current_mutrec_block -> + [%expr Elpi.API.ContextualConversion.TyApp([%e evar @@ elpi_tname_str id],[%e find_ty_ast_of (module B) current_mutrec_block p],[%e elist @@ List.map (find_ty_ast_of (module B) current_mutrec_block) ps ])] + | [%type: [%t? typ] list] -> [%expr Elpi.API.ContextualConversion.TyApp("list", [%e find_ty_ast_of (module B) current_mutrec_block typ ], [])] + | [%type: [%t? typ] option] -> [%expr Elpi.API.ContextualConversion.TyApp("option", [%e find_ty_ast_of (module B) current_mutrec_block typ ], [])] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.API.ContextualConversion.TyApp("pair", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ] ])] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.API.ContextualConversion.TyApp("triple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ] ])] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.API.ContextualConversion.TyApp("quadruple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ4 ] ])] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.API.ContextualConversion.TyApp("quintuple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ4 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ5 ] ])] + | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.ContextualConversion.ty ] + +let find_mapper_of (module B : Ast_builder.S) current_mutrec_block params ty = let open B in + let rec aux ty = + match ty with + | [%type: [%t? typ] list] -> [%expr Printf.sprintf "(ppx.map.list %s)" [%e aux typ] ] + | [%type: [%t? typ] option] -> [%expr Printf.sprintf "(ppx.map.option %s)" [%e aux typ] ] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Printf.sprintf "(ppx.map.pair %s %s)" [%e aux typ1] [%e aux typ2] ] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Printf.sprintf "(ppx.map.triple %s %s %s)" [%e aux typ1] [%e aux typ2] [%e aux typ3] ] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Printf.sprintf "(ppx.map.quadruple %s %s %s %s)" [%e aux typ1] [%e aux typ2] [%e aux typ3] [%e aux typ4] ] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Printf.sprintf "(ppx.map.quintuple %s %s %s %s %s)" [%e aux typ1] [%e aux typ2] [%e aux typ3] [%e aux typ4] [%e aux typ5] ] + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, []); _ } when List.mem_assoc id params -> + estring @@ List.assoc id params + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, []); _ } when List.mem id current_mutrec_block -> + [%expr "map." ^ [%e evar @@ elpi_tname_str id]] + | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, ps); _ } when List.mem id current_mutrec_block -> + [%expr "(map." ^ [%e evar @@ elpi_tname_str id] ^ " " ^ String.concat " " [%e elist @@ List.map (aux) ps] ^ ")"] + | _ -> [%expr "(=)"] + in + fun (v1,v2) -> [%expr "(" ^ [%e aux ty] ^ " " ^ [%e estring v1 ] ^ " " ^[%e estring v2 ] ^ ")" ] +;; + +let one_string = function + | { pexp_desc = Pexp_constant (Pconst_string(s,_)); _ } -> Some s + | _ -> None + +let one_or_two_strings (module B : Ast_builder.S) = function + | Pexp_constant (Pconst_string (s,_)) -> s, None + | Pexp_apply(x,[_,y]) when is_some (one_string x) && is_some (one_string y) -> + option_get (one_string x), one_string y + | _ -> error "string or ident expected" + +let get_elpi_code (module B : Ast_builder.S) kname kattributes = + match Attribute.get att_elpi_code kattributes with + | None -> elpi_name_mangle kname, None + | Some payload -> one_or_two_strings (module B) payload.pexp_desc + +let get_elpi_tcode (module B : Ast_builder.S) kname kattributes = + match Attribute.get att_elpi_tcode kattributes with + | None -> elpi_name_mangle kname, None + | Some payload -> one_or_two_strings (module B) payload.pexp_desc + +let get_elpi_doc kname kattributes = + option_default kname (Attribute.get att_elpi_doc kattributes) +let get_elpi_tdoc kname kattributes = + option_default kname (Attribute.get att_elpi_tdoc kattributes) +let get_elpi_treadback tattributes = + Attribute.get att_elpi_treadback tattributes +let get_elpi_pp tattributes = + Attribute.get att_elpi_pp tattributes + +let analyze_tuple_constructor (module B : Ast_builder.S) tyname kname kattributes tl constructor pattern same_mutrec_block = let open B in + let c_str = elpi_kname_str tyname kname in + let c = elpi_kname tyname kname in + let elpi_doc = get_elpi_doc kname kattributes in + let str, elpi_code = get_elpi_code (module B) kname kattributes in + let decl_str = value_binding ~pat:(pvar c_str) ~expr:(estring str) in + let decl = value_binding ~pat:(pvar c) ~expr:[%expr Elpi.API.RawData.Constants.declare_global_symbol [%e evar @@ c_str ] ] in + let tl = + tl |> List.map (fun t -> + match Attribute.get att_elpi_binder t with + | Some { pexp_desc = Pexp_apply({ pexp_desc = Pexp_ident { txt; _}; _},[_,arg]) ; _ } -> + HO { + argHO_arrow_src = String.concat "." @@ Longident.flatten_exn txt; + argHO_build_ctx = arg; + argHO_readback = find_readback_of (module B) same_mutrec_block t; + argHO_embed = find_embed_of (module B) same_mutrec_block t; + argHO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; + argHO_ty = t; + } + | Some { pexp_desc = Pexp_apply({ pexp_desc = Pexp_constant (Pconst_string(txt,_)); _},[_,arg]) ; _ } -> + HO { + argHO_arrow_src = txt; + argHO_build_ctx = arg; + argHO_readback = find_readback_of (module B) same_mutrec_block t; + argHO_embed = find_embed_of (module B) same_mutrec_block t; + argHO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; + argHO_ty = t; + } + | Some e -> + HO{ + argHO_arrow_src = tyname; + argHO_build_ctx = e; + argHO_readback = find_readback_of (module B) same_mutrec_block t; + argHO_embed = find_embed_of (module B) same_mutrec_block t; + argHO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; + argHO_ty = t; + } + | None -> + let argFO_key = None <> Attribute.get att_elpi_key t in + FO { + argFO_readback = find_readback_of (module B) same_mutrec_block t; + argFO_embed = find_embed_of (module B) same_mutrec_block t; + argFO_key; + argFO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; + argFO_ty = t; + }) in + let readback = Attribute.get att_elpi_readback kattributes in + let embed = Attribute.get att_elpi_embed kattributes in + let readback, embed = + let var_ = option_map (option_default [%expr fun x -> x]) (Attribute.get att_elpi_var kattributes) in + let opt2custom = function None -> Standard | Some x -> Custom(x,B.loc.loc_end) in + match readback, embed, var_ with + | _, _, None -> opt2custom readback, opt2custom embed + | None, None, Some p -> + if List.length tl = 1 then Name p, Name p + else error "[@elpi.var] on a constructor with zero or more than one argument and not [@elpi.readback]" + | None, (Some _ as e), Some p -> + if List.length tl = 1 then Name p, opt2custom e + else error "[@elpi.var] on a constructor with more than one argument and not [@elpi.readback]" + | (Some _ as r), None, Some p -> opt2custom r, Name p + | Some _, Some _, Some _ -> error "[@elpi.var] on a constructor with [@elpi.readback] and [@elpi.embed]" in + Expose { declaration = [pstr_value Nonrecursive [decl_str]; pstr_value Nonrecursive [decl]] ; constant = evar c; constant_name = str; elpi_code = option_map estring elpi_code; elpi_doc; types = tl; constructor; pattern; embed; readback } +;; + +let analyze_constructor (module B : Ast_builder.S) tyname same_mutrec_block decl = let open B in + match decl with + | { pcd_name = { txt = kname ; _ }; pcd_args; _ } when Attribute.get att_elpi_skip decl = Some () -> + Skip { constructor_name = kname; has_args = not (pcd_args = Pcstr_tuple []) } + | { pcd_name = { txt = kname ; _ }; pcd_args = Pcstr_tuple tl; pcd_res = None; _ } -> + let make_k args = + if args = [] then pexp_construct (Located.lident kname) None + else pexp_construct (Located.lident kname) (Some (pexp_tuple args)) in + let match_k args = + if args = [] then ppat_construct (Located.lident kname) None + else ppat_construct (Located.lident kname) (Some (ppat_tuple args)) in + analyze_tuple_constructor (module B) tyname kname decl tl make_k match_k same_mutrec_block + | { pcd_name = { txt = kname ; _ }; pcd_args = Pcstr_record lbltl; pcd_res = None; _ } -> + let lbls, tl = List.(split (map (fun { pld_name = { txt; _ }; pld_type; _} -> txt, pld_type) lbltl)) in + let make_k args = pexp_construct (Located.lident kname) (Some (pexp_record (List.map2 (fun x y -> B.Located.lident x,y) lbls args) None)) in + let match_k args = ppat_construct (Located.lident kname) (Some (ppat_record (List.map2 (fun x y -> B.Located.lident x,y) lbls args) Closed)) in + analyze_tuple_constructor (module B) tyname kname decl tl make_k match_k same_mutrec_block + | { pcd_loc = loc; _ } -> error ~loc "unsupportd constructor declaration" + +let extract_tyvar (x,_) = + match x.ptyp_desc with + | Ptyp_var s -> s + | _ -> error ~loc:x.ptyp_loc "Type abstracted over something that is not a type variable" + +let analyze_params (module B : Ast_builder.S) params = let open B in + let tyvars = List.map extract_tyvar params in + let mapper = object + inherit Ast_traverse.map as super + method! core_type x = + match x.ptyp_desc with + | Ptyp_var x when List.mem x tyvars -> ptyp_constr (B.Located.mk (Longident.parse @@ param_prefix ^ x)) [] + | _ -> super#core_type x + end in + List.map ((^) param_prefix) tyvars, mapper + +let mk_kind (module B : Ast_builder.S) vl name = let open B in + match List.map (fun x -> [%expr [%e evar x ].Elpi.API.ContextualConversion.ty]) vl with + | [] -> [%expr Elpi.API.ContextualConversion.TyName [%e name ]] + | x :: xs -> [%expr Elpi.API.ContextualConversion.TyApp([%e name], [%e x], [%e elist @@ xs])] + +let consistency_check ~loc (tyd,kind) = + let name, csts = + match tyd with + | { name; type_decl = Algebraic (l,_); _ } -> name, drop_skip l + | { name; _ } -> name, [] in + let some_have_key = + List.exists (fun { types; _ } -> List.exists is_key types) csts in + let some_have_under = + List.exists (fun { types; _ } -> List.exists is_HO types) csts in + let all_have_1_key = + List.for_all (fun { types; _ } -> + 1 = List.(length (filter is_key types))) csts in + let some_k_is_var = + List.exists (function { embed = Name _; _ } | { readback = Name _; _ } -> true | _ -> false) csts in + match kind with + | ADT when some_have_key || some_k_is_var || some_have_under-> + error ~loc "type %s is a simple ADT but uses [@elpi.var] or [@elpi.key] or [@elpi.binder]. Use [@@elpi : type] to make it a HOADT or [@@elpi (module M)] to make it a context ADT" name + | CTX _ when not all_have_1_key -> + error ~loc "type %s is a context ADT but has a constructor that does not have exactly one argumet marked as [@elpi.key]" name + | CTX _ when tyd.params <> [] -> + error ~loc "type %s is a context ADT but has parameters, not supported" name + | HOAS _ when not (some_k_is_var || some_have_under) -> + error ~loc "type %s is a HOADT but has no constructor flagged as [@elpi.var] nor arguments flagged as [@elpi.binder]" name + | _ -> () +;; + +let pp_doc (module B : Ast_builder.S) kind elpi_name elpi_code elpi_doc is_pred csts = let open B in [%expr fun fmt () -> + [%e match elpi_code with + | None -> [%expr Elpi.API.PPX.Doc.kind fmt [%e kind] ~doc:[%e estring elpi_doc ] ] + | Some code -> + [%expr + Elpi.API.Doc.comment fmt ("% " ^ [%e estring elpi_doc ]); + Format.fprintf fmt "@\n@[kind %s@[ %s.@]@]@\n" + [%e elpi_name ] [%e code ] ] + ] ; + [%e esequence @@ + List.(concat @@ (drop_skip csts |> map (fun { constant_name = c; types; embed; readback; elpi_code; elpi_doc; _ } -> + let types, ty = + if is_pred then ctx_index_ty (module B) :: types, [%expr Elpi.API.ContextualConversion.TyName "prop"] + else types, [%expr kind ] in + if is_name embed || is_name readback then [] + else [ + match elpi_code with + | Some code -> + [%expr + Format.fprintf fmt "@[type %s@[ %s. %% %s@]@]@\n" [%e estring c] [%e code] [%e estring elpi_doc ]] + | None -> [%expr Elpi.API.PPX.Doc.constructor fmt + ~ty:[%e ty ] + ~name:[%e estring c] + ~doc:[%e estring elpi_doc ] + ~args:[%e elist @@ List.map (function + | FO { argFO_ty_ast; _ } -> argFO_ty_ast + | HO { argHO_arrow_src = s; argHO_ty_ast; _ } -> + [%expr Elpi.API.ContextualConversion.TyApp("->", + Elpi.API.ContextualConversion.TyName [%e estring s], + [[%e argHO_ty_ast]]) ] + ) types] + ]]))) + ]] +;; + + +let typeabbrev_for (module B : Ast_builder.S) f params = let open B in + let vars = List.mapi (fun i _ -> Printf.sprintf "A%d" i) params in + if params = [] then f else [%expr "(" ^ [%e f] ^ " " ^ [%e estring (String.concat " " vars) ] ^")" ] + +let typeabbrev_for_conv (module B : Ast_builder.S) ct = let open B in + [%expr Elpi.API.PPX.Doc.show_ty_ast ~outer: false @@ [%e conversion_of (module B) ct].Elpi.API.ContextualConversion.ty ] + +let mk_pp_name (module B : Ast_builder.S) name = function + | None -> if name = "t" then B.evar "pp" else B.evar ("pp_" ^ name) + | Some e -> e + +let pp_for_conversion (module B : Ast_builder.S) name is_pred params pp = let open B in + let pp = mk_pp_name (module B) name pp in + if is_pred then [%expr fun fmt (_,x) -> [%e pp] fmt x] + else eapply pp (List.map (fun x -> [%expr [%e evar x].pp]) params) + +let quantify_ty_over_params (module B : Ast_builder.S) params t = let open B in + ptyp_poly (List.map Located.mk params) t + +let conversion_type (module B : Ast_builder.S) name params is_pred = let open B in + let rec aux = function + | [] -> + let t = ptyp_constr (Located.lident name) (List.map ptyp_var params) in + let t = if is_pred then ptyp_tuple [ [%type: Elpi.API.RawData.constant ] ;t] else t in + [%type: ([%t t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.t] + | t :: ts -> [%type: ([%t ptyp_var t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.t -> [%t aux ts]] + in + quantify_ty_over_params (module B) (params @ ["elpi__param__poly_hyps"; "elpi__param__poly_csts"]) (aux params) + + +let readback_type (module B : Ast_builder.S) name params is_pred = let open B in + let rec aux = function + | [] -> + let t = ptyp_constr (Located.lident name) (List.map ptyp_var params) in + let t = if is_pred then ptyp_tuple [ [%type: Elpi.API.RawData.constant ] ;t] else t in + [%type: ([%t t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback] + | t :: ts -> [%type: ([%t ptyp_var t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback -> [%t aux ts]] + in + quantify_ty_over_params (module B) (params @ ["elpi__param__poly_hyps"; "elpi__param__poly_csts"]) (aux params) + +let embed_type (module B : Ast_builder.S) name params is_pred = let open B in + let rec aux = function + | [] -> + let t = ptyp_constr (Located.lident name) (List.map ptyp_var params) in + let t = if is_pred then ptyp_tuple [ [%type: Elpi.API.RawData.constant ] ;t] else t in + [%type: ([%t t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding] + | t :: ts -> [%type: ([%t ptyp_var t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding -> [%t aux ts]] + in + quantify_ty_over_params (module B) (params @ ["elpi__param__poly_hyps"; "elpi__param__poly_csts"]) (aux params) + + +let coversion_for_opaque (module B : Ast_builder.S) elpi_name name pp = let open B in + value_binding ~pat:(ppat_constraint (pvar name) [%type: [%t ptyp_constr (Located.lident name) []] Elpi.API.Conversion.t]) ~expr:[%expr + Elpi.API.OpaqueData.declare { + Elpi.API.OpaqueData.name = [%e elpi_name ] ; + doc = ""; + pp = ([%e mk_pp_name (module B) name pp ]); + compare = Pervasives.compare; + hash = Hashtbl.hash; + hconsed = false; + constants = []; + } + ] + +let conversion_for_alias (module B : Ast_builder.S) orig name params _same_mutrec_block = let open B in + let conv = conversion_of (module B) orig in + value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params false)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) conv) + +let conversion_for_tyd (module B : Ast_builder.S) is_pred _same_mutrec_block { name; params; elpi_name; elpi_code; elpi_doc; type_decl; pp } = let open B in + match type_decl with + | Opaque -> coversion_for_opaque (module B) (estring elpi_name) name pp + | Alias _ -> + value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params is_pred)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) ([%expr + let kind = [%e mk_kind (module B) params (estring elpi_name) ] in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = [%e pp_doc (module B) [%expr kind] (estring elpi_name) (option_map estring elpi_code) elpi_doc is_pred [] ]; + pp = [%e pp_for_conversion (module B) name is_pred params pp ]; + embed = [%e eapply (evar (elpi_embed_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.embed]) params) ]; + readback = [%e eapply (evar (elpi_readback_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.readback]) params) ]; + }])) + | Algebraic(csts,_)-> + value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params is_pred)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) ([%expr + let kind = [%e mk_kind (module B) params (estring elpi_name) ] in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = [%e pp_doc (module B) [%expr kind] (estring elpi_name) (option_map estring elpi_code) elpi_doc is_pred csts ]; + pp = [%e pp_for_conversion (module B) name is_pred params pp ]; + embed = [%e eapply (evar (elpi_embed_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.embed]) params) ]; + readback = [%e eapply (evar (elpi_readback_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.readback]) params) ]; + }])) +;; + +let embed_for_tyd (module B : Ast_builder.S) (is_pred,ctx) same_mutrec_block { name; params; type_decl; _ } = let open B in + match type_decl with + | Opaque -> if params <> [] then error ~loc "opaque data type with parameters not supported"; + value_binding ~pat:(pvar (elpi_embed_name name)) ~expr:[%expr fun ~depth _ _ s t -> [%e evar name].Elpi.API.Conversion.embed ~depth s t ] + | Alias orig -> + value_binding ~pat:(ppat_constraint (pvar (elpi_embed_name name)) (embed_type (module B) name params is_pred)) + ~expr:(abstract_expr_over_params (module B) params elpi_embed_name @@ [%expr fun ~depth h c s t -> [%e find_embed_of (module B) same_mutrec_block orig] ~depth h c s t]) + | Algebraic(csts,_) -> + value_binding ~pat:(ppat_constraint (pvar (elpi_embed_name name)) (embed_type (module B) name params is_pred)) + ~expr:(abstract_expr_over_params (module B) params elpi_embed_name @@ embed (module B) name (is_pred,ctx) csts) + +let readback_for_tyd (module B : Ast_builder.S) (is_pred,ctx) same_mutrec_block { name; params; type_decl; _ } = let open B in + match type_decl with + | Opaque -> if params <> [] then error ~loc "opaque data type with parameters not supported"; + value_binding ~pat:(pvar (elpi_readback_name name)) ~expr:[%expr fun ~depth _ _ s t -> [%e evar name].Elpi.API.Conversion.readback ~depth s t ] + | Alias orig -> + value_binding ~pat:(ppat_constraint (pvar (elpi_readback_name name)) (readback_type (module B) name params is_pred)) + ~expr:(abstract_expr_over_params (module B) params elpi_readback_name @@ [%expr fun ~depth h c s t -> [%e find_readback_of (module B) same_mutrec_block orig] ~depth h c s t]) + | Algebraic(csts,def_readback) -> + value_binding ~pat:(ppat_constraint (pvar (elpi_readback_name name)) (readback_type (module B) name params is_pred)) + ~expr:(abstract_expr_over_params (module B) params elpi_readback_name @@ readback (module B) name (is_pred,ctx) def_readback csts) + +let constants_of_tyd (module B : Ast_builder.S) { type_decl ; elpi_name; name; _ } = let open B in + let c_str = elpi_tname_str name in + let decl_str = + value_binding ~pat:(pvar c_str) ~expr:(estring elpi_name) in + let decl = + let c = elpi_tname name in + value_binding ~pat:(pvar c) ~expr:[%expr Elpi.API.RawData.Constants.declare_global_symbol [%e evar c_str ]] in + pstr_value Nonrecursive [decl_str] :: + pstr_value Nonrecursive [decl] :: + match type_decl with + | Alias _ -> [] + | Opaque -> [] + | Algebraic (csts,_) -> List.flatten @@ List.map (fun x -> x.declaration) @@ drop_skip csts + +let elpi_declaration_of_tyd (module B : Ast_builder.S) tyd = let open B in + let decl_name = "elpi_"^tyd.name in + let decl = + match tyd.type_decl with + | Alias orig -> + (if tyd.params = [] then (fun x -> x) + else pexp_let Nonrecursive (List.mapi (fun i x -> value_binding ~pat:(pvar x) ~expr:[%expr Elpi.API.ContextualConversion.(!>) @@ Elpi.API.BuiltInData.poly (Printf.sprintf "A%d" [%e eint i]) ]) tyd.params)) + [%expr + Elpi.API.BuiltIn.LPCode ("typeabbrev " ^ + [%e typeabbrev_for (module B) (estring tyd.elpi_name) tyd.params ] ^ " " ^ + [%e typeabbrev_for_conv (module B) orig ] ^ ". % " ^ [%e estring tyd.elpi_doc ]) ] + | Opaque -> + [%expr Elpi.API.BuiltIn.MLData [%e + if tyd.params = [] then evar tyd.name + else error ~loc "opaque with params" ]] + | Algebraic _ -> + let vars = List.mapi (fun i _ -> [%expr Elpi.API.ContextualConversion.(!>) @@ Elpi.API.BuiltInData.poly [%e estring @@ Printf.sprintf "A%d" i] ]) tyd.params in + [%expr Elpi.API.BuiltIn.MLDataC [%e + if tyd.params = [] then evar tyd.name + else eapply (evar tyd.name) vars]] in + { decl = pstr_value Nonrecursive [value_binding ~pat:(pvar decl_name) ~expr:decl]; + decl_name = evar decl_name; } + +let mapper_for_tyd (module B : Ast_builder.S) is_pred same_block tyd = let open B in + if is_pred then None else + let tyvars = List.mapi (fun i _ -> Printf.sprintf "X%d" i) tyd.params in + let tyvars1 = List.mapi (fun i _ -> Printf.sprintf "Y%d" i) tyd.params in + let ty_w_params vars = + if vars = [] then tyd.elpi_name + else tyd.elpi_name ^ " " ^ String.concat " " vars in + let fvars = List.mapi (fun i _ -> Printf.sprintf "F%d" i) tyd.params in + let param2fv = List.combine tyd.params fvars in + let ty_fvars = + if tyvars = [] then "" + else String.concat ", " (List.map2 (Printf.sprintf "i:(%s -> %s -> prop)") tyvars tyvars1) ^ ", " in + let pred_decl = + estring @@ Printf.sprintf "pred map.%s %s i:%s, o:%s." tyd.elpi_name ty_fvars (ty_w_params tyvars) (ty_w_params tyvars1) in + let fvars_str = if fvars = [] then "" else (String.concat " " fvars ^ " ") in + match tyd.type_decl with + | Opaque -> None + | Alias orig -> + let mapper = + [%expr Printf.sprintf "map.%s %sA B :- %s." + [%e estring @@ tyd.elpi_name] + [%e estring @@ fvars_str] + [%e find_mapper_of (module B) same_block param2fv orig ("A","B") ]] in + Some [%expr String.concat "\n" [%e elist [pred_decl ; mapper]]] + | Algebraic(csts,_) -> + let mapka ty (v1,v2) = + match ty with + | FO { argFO_ty; _ } -> find_mapper_of (module B) same_block param2fv argFO_ty (v1,v2) + | HO _ -> [%expr Printf.sprintf "(pi x\ fixme x => (=) %s %s)" [%e estring @@ v1] [%e estring @@ v2] ] in + let mapk { constant_name; types; _ } = + if types = [] then + estring @@ Printf.sprintf "map.%s %s%s %s." tyd.elpi_name fvars_str constant_name constant_name + else + let vars = List.mapi (fun i _ -> Printf.sprintf "A%d" i) types in + let vars1 = List.mapi (fun i _ -> Printf.sprintf "B%d" i) types in + let vars_s = String.concat " " vars in + let vars1_s = String.concat " " vars1 in + let body = List.map2 mapka types (List.combine vars vars1) in + [%expr Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." + [%e estring @@ tyd.elpi_name] + [%e estring @@ fvars_str] + [%e estring @@ constant_name] + [%e estring @@ vars_s] + [%e estring @@ constant_name] + [%e estring @@ vars1_s] + (String.concat ", " [%e elist @@ body])] in + let mapper = List.map mapk (drop_skip csts) in + Some [%expr String.concat "\n" [%e elist @@ (pred_decl :: mapper @ [estring "\n"])]] + +let extras_of_task (module B : Ast_builder.S) (tyd,kind) same_mutrec_block = let open B in + match kind with + | ADT -> { + ty_constants = constants_of_tyd (module B) tyd; + ty_embed = embed_for_tyd (module B) (false,None) same_mutrec_block tyd; + ty_readback = readback_for_tyd (module B) (false,None) same_mutrec_block tyd; + ty_conversion = conversion_for_tyd (module B) false same_mutrec_block tyd; + ty_conversion_name = tyd.name; + ty_context_helpers = []; + ty_context_readback = []; + ty_elpi_declaration = elpi_declaration_of_tyd (module B) tyd; + ty_opaque = tyd.type_decl = Opaque; + ty_library = mapper_for_tyd (module B) false same_mutrec_block tyd; + } + + | HOAS ctx -> { + ty_constants = constants_of_tyd (module B) tyd; + ty_embed = embed_for_tyd (module B) (false,Some ctx) same_mutrec_block tyd; + ty_readback = readback_for_tyd (module B) (false,Some ctx) same_mutrec_block tyd; + + ty_conversion = conversion_for_tyd (module B) false same_mutrec_block tyd; + ty_conversion_name = tyd.name; + ty_context_helpers = []; + ty_context_readback = []; + ty_elpi_declaration = elpi_declaration_of_tyd (module B) tyd; + ty_opaque = tyd.type_decl = Opaque; + ty_library = mapper_for_tyd (module B) false same_mutrec_block tyd; + } + + | CTX (m,deps) -> + let name = tyd.name in + let elpi_Map = elpi_Map ~loc name in + let elpi_name = tyd.elpi_name in + let csts = match tyd.type_decl with Algebraic(x,_) -> x | _ -> error "context ADT must be explicit" in + { + ty_constants = constants_of_tyd (module B) tyd; + ty_embed = embed_for_tyd (module B) (true,None) same_mutrec_block tyd; + ty_readback = readback_for_tyd (module B) (true,None) same_mutrec_block tyd; + ty_conversion = conversion_for_tyd (module B) true same_mutrec_block tyd; + ty_conversion_name = tyd.name; + ty_context_helpers = [ + pstr_module (module_binding ~name:(Located.mk (elpi_map_name name)) + ~expr:(pmod_apply (pmod_ident (Located.mk (Longident.parse "Elpi.API.Utils.Map.Make"))) m)); + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_state_name name)) ~expr:[%expr + Elpi.API.State.declare ~name:[%e estring elpi_name] ~pp:(fun fmt _ -> Format.fprintf fmt "TODO") + ~init:(fun () -> + ([%e elpi_Map "empty" ] : + [%t ptyp_constr (Located.lident (elpi_map_name name ^ ".t")) [ [%type: Elpi.API.RawData.constant] ] ]), + (Elpi.API.RawData.Constants.Map.empty : [%t ptyp_constr (Located.lident name) [] ] Elpi.API.ContextualConversion.ctx_entry Elpi.API.RawData.Constants.Map.t)) + ]]; + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_to_key name)) ~expr:(ctx_entry_key (module B) csts)]; + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_is_ctx_entry_name name)) ~expr:(is_ctx_entry (module B) csts)]; + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_push name)) ~expr:(ctx_push (module B) name)]; + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_pop name)) ~expr:(ctx_pop (module B) name)]; + ]; + ty_context_readback = [ + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_in_name_alone name)) ~expr:(ctx_readback (module B) name)]; + pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_in_name name)) ~expr:( + compose_ctx_readback (module B) (deps @ [name]) + )] + ]; + ty_elpi_declaration = elpi_declaration_of_tyd (module B) tyd; + ty_opaque = tyd.type_decl = Opaque; + ty_library = mapper_for_tyd (module B) true same_mutrec_block tyd; + } +;; + +let analyze_typedecl (module B : Ast_builder.S) same_mutrec_block tdecl = + match tdecl with + | { + ptype_name = { txt = name ; _ }; + ptype_params = params; + ptype_cstrs = []; + ptype_kind = Ptype_abstract; + ptype_manifest = None; + _ + } -> + let params, _ = analyze_params (module B) params in + let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in + let elpi_doc = get_elpi_tdoc name tdecl in + let pp = get_elpi_pp tdecl in + { name; params; type_decl = Opaque; elpi_name; elpi_code; elpi_doc; pp } + + | { + ptype_name = { txt = name ; _ }; + ptype_params = params; + ptype_cstrs = []; + ptype_kind = Ptype_abstract; + ptype_manifest = Some alias; + _ + } -> + let params, typ = analyze_params (module B) params in + let alias = typ#core_type alias in + let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in + let elpi_doc = get_elpi_tdoc name tdecl in + let pp = get_elpi_pp tdecl in + { name; params; type_decl = Alias alias; elpi_name; elpi_code; elpi_doc; pp } + + | { + ptype_name = { txt = name ; _ }; + ptype_params = params; + ptype_cstrs = []; + ptype_kind = Ptype_variant csts; + _ + } -> + let params, typ = analyze_params (module B) params in + let csts = List.map typ#constructor_declaration csts in + let csts = List.map (analyze_constructor (module B) name same_mutrec_block) csts in + let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in + let elpi_doc = get_elpi_tdoc name tdecl in + let default_readback = get_elpi_treadback tdecl in + let pp = get_elpi_pp tdecl in + { name; params; type_decl = Algebraic(csts,default_readback); elpi_name; elpi_code; elpi_doc; pp } + + | { + ptype_name = { txt = name ; _ }; + ptype_params = params; + ptype_cstrs = []; + ptype_kind = Ptype_record lbltl; + ptype_attributes; + _ + } -> + let params, typ = analyze_params (module B) params in + let lbltl = List.map typ#label_declaration lbltl in + let lbls, tl = List.(split (map (fun { pld_name = { txt; _ }; pld_type; _} -> txt, pld_type) lbltl)) in + let make_k args = B.pexp_record (List.map2 (fun x y -> B.Located.lident x, y) lbls args) None in + let match_k args = B.ppat_record (List.map2 (fun x y -> B.Located.lident x, y) lbls args) Closed in + let kdecl = { + pcd_name = B.Located.mk name; + pcd_args = Pcstr_tuple []; + pcd_res = None; + pcd_loc = B.loc; + pcd_attributes = ptype_attributes; + } in + let csts = [analyze_tuple_constructor (module B) name name kdecl tl make_k match_k same_mutrec_block] in + let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in + let elpi_doc = get_elpi_tdoc name tdecl in + let default_readback = get_elpi_treadback tdecl in + let pp = get_elpi_pp tdecl in + { name; params; type_decl = Algebraic(csts,default_readback); elpi_name; elpi_code; elpi_doc; pp } + + | _ -> error ~loc:B.loc "unsupportd type declaration" +;; + +let typedecl_extras index context (module B : Ast_builder.S) tyd_names tyd = + let open B in + let tyd = analyze_typedecl (module B) tyd_names tyd in + let one_ty t = + match t.ptyp_desc with + | Ptyp_constr({ txt; _ },args) -> + if args <> [] then nYI ~loc ~__LOC__ () + else + if List.length (Longident.flatten_exn txt) > 1 then nYI ~loc ~__LOC__ () + else String.concat "." (Longident.flatten_exn txt) + | _ -> error ~loc "[elpi.context] payload is invalid: %a" Ocaml_common.Pprintast.core_type (Selected_ast.To_ocaml.copy_core_type t) in + let one_arrow t = + match t.ptyp_desc with + | Ptyp_arrow(_,s,t) -> one_ty s , one_ty t + | _ -> error ~loc "[elpi.context] payload is invalid: %a" Ocaml_common.Pprintast.core_type (Selected_ast.To_ocaml.copy_core_type t) in + let kind = + match index, context with + | None, None -> ADT + | Some m, None -> CTX(m,[]) + | Some m, Some ty -> CTX(m,[one_ty ty]) + | None, Some ty -> + match ty.ptyp_desc with + | Ptyp_tuple l -> HOAS (List.map one_arrow l) + | Ptyp_arrow _ -> HOAS [one_arrow ty] + | _ -> HOAS [tyd.name, one_ty ty] + in + let task = tyd, kind in + + consistency_check ~loc:B.loc task; + + extras_of_task (module B) task tyd_names +;; + +let tydecls ~loc index context append _r tdls = + let module B = Ast_builder.Make(struct let loc = loc end) in + let open B in + let extra = List.map (typedecl_extras index context (module B) (List.map (fun x -> x.ptype_name.txt) tdls)) tdls in + let opaque_extra, non_opaque_extra = List.partition (fun x -> x.ty_opaque) extra in + + pstr_attribute { attr_name = Located.mk "warning"; attr_payload = PStr [pstr_eval (estring "-26-27-32-39-60") []]; attr_loc = loc } :: + + List.(concat (map (fun x -> x.ty_constants) extra)) @ + List.(concat (map (fun x -> x.ty_context_helpers) extra)) @ + + begin if opaque_extra <> [] then + List.(map (fun x -> pstr_value Nonrecursive [x.ty_conversion]) opaque_extra) @ + [pstr_value Nonrecursive List.(map (fun x -> x.ty_embed) opaque_extra)] @ + [pstr_value Nonrecursive List.(map (fun x -> x.ty_readback) opaque_extra)] + else [] end @ + + begin if non_opaque_extra <> [] then + [pstr_value Recursive List.(map (fun x -> x.ty_embed) non_opaque_extra)] @ + [pstr_value Recursive List.(map (fun x -> x.ty_readback) non_opaque_extra)] @ + List.(map (fun x -> pstr_value Nonrecursive [x.ty_conversion]) non_opaque_extra) + else [] end @ + + List.(concat (map (fun x -> x.ty_context_readback) extra)) @ + List.(map (fun x -> x.ty_elpi_declaration.decl) extra) @ + match append with + | None -> [] + | Some l -> [pstr_value Nonrecursive [value_binding ~pat:(punit) + ~expr:[%expr [%e l] := ![%e l] @ + [%e elist @@ List.(map (fun x -> x.ty_elpi_declaration.decl_name) extra) ] + @ + [%e elist @@ List.concat (List.map (fun x -> + match x.ty_library with + | None -> [] + | Some e -> [[%expr Elpi.API.BuiltIn.LPCode [%e e]]]) extra)] + ]]] +;; + +let conversion_of_expansion ~loc ~path:_ ty = + conversion_of (module Ast_builder.Make(struct let loc = loc end)) ty + +let conversion_extension = + Extension.declare + "elpi" + Extension.Context.expression + Ast_pattern.(ptyp __) + conversion_of_expansion + +let expand_str ~loc ~path:_ (r,tydecl) (index : module_expr option) (context : core_type option) (append : expression option) = tydecls ~loc index context append r tydecl +let expand_sig ~loc ~path:_ (_r,_tydecl) (_index : module_expr option) (_context : core_type option) = nYI ~loc ~__LOC__ () + +let attributes = Attribute.([ + T att_elpi_tcode; + T att_elpi_tdoc; + T att_elpi_var ; + T att_elpi_skip ; + T att_elpi_embed; + T att_elpi_readback; + T att_elpi_code; + T att_elpi_doc; + T att_elpi_key; + T att_elpi_binder +]) + + +let str_type_decl_generator = + Deriving.Generator.make + ~attributes + arguments + expand_str + +let pexp_ignore = Deriving.Args.of_func (fun _ _ (_e : expression) b -> b) + +let arguments = Deriving.Args.(empty + +> arg "index" (pexp_pack __) + +> arg "context" (pexp_constraint pexp_ignore __) +) + +let sig_type_decl_generator = + Deriving.Generator.make + ~attributes + arguments + expand_sig + +let my_deriver = + Deriving.add + ~str_type_decl:str_type_decl_generator + ~sig_type_decl:sig_type_decl_generator + "elpi" + +let () = + Driver.register_transformation + ~extensions:[ conversion_extension; ] + "elpi.conversion" \ No newline at end of file diff --git a/ppx_elpi/tests/README.md b/ppx_elpi/tests/README.md new file mode 100644 index 000000000..bb7f8ac2e --- /dev/null +++ b/ppx_elpi/tests/README.md @@ -0,0 +1,17 @@ +## Usage + +To add a new test + +```shell +touch test_XXX.ml +touch test_XXX.expected.ml +touch test_XXX.expected.elpi +dune runtest --auto-promote # promotes the dune file +``` + +As a template for `test_XXX.ml` you should use test_simple_adt.ml + +To run tests and acknowledge a change +```shell +dune runtest --auto-promote # promotes the output +``` diff --git a/ppx_elpi/tests/dune b/ppx_elpi/tests/dune new file mode 100644 index 000000000..3f3fa4343 --- /dev/null +++ b/ppx_elpi/tests/dune @@ -0,0 +1,27 @@ +(env + (dev + (flags (:standard -warn-error -A)))) + +(executable + (name pp) + (modules pp) + (libraries elpi.ppx ppxlib)) + +(include dune.inc) + +(executable + (name gen_dune) + (libraries re) + (modules gen_dune) +) + +(rule + (targets dune.inc.gen) + (deps (:gen gen_dune.exe) (source_tree .)) + (action (with-stdout-to %{targets} (run %{gen}))) +) + +(rule + (alias runtest) + (action (diff dune.inc dune.inc.gen)) +) \ No newline at end of file diff --git a/ppx_elpi/tests/dune.inc b/ppx_elpi/tests/dune.inc new file mode 100644 index 000000000..a7e9e99e4 --- /dev/null +++ b/ppx_elpi/tests/dune.inc @@ -0,0 +1,253 @@ + +(rule + (targets test_alias_type.actual.ml) + (deps (:pp pp.exe) (:input test_alias_type.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_alias_type.expected.ml test_alias_type.actual.ml))) + +(rule + (alias runtest) + (action (diff test_alias_type.expected.elpi test_alias_type.actual.elpi))) + +(rule + (target test_alias_type.actual.elpi) + (action (run ./test_alias_type.exe %{target}))) + +(executable + (name test_alias_type) + (modules test_alias_type) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_double_contextual.actual.ml) + (deps (:pp pp.exe) (:input test_double_contextual.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_double_contextual.expected.ml test_double_contextual.actual.ml))) + +(rule + (alias runtest) + (action (diff test_double_contextual.expected.elpi test_double_contextual.actual.elpi))) + +(rule + (target test_double_contextual.actual.elpi) + (action (run ./test_double_contextual.exe %{target}))) + +(executable + (name test_double_contextual) + (modules test_double_contextual) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_mutual_adt.actual.ml) + (deps (:pp pp.exe) (:input test_mutual_adt.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_mutual_adt.expected.ml test_mutual_adt.actual.ml))) + +(rule + (alias runtest) + (action (diff test_mutual_adt.expected.elpi test_mutual_adt.actual.elpi))) + +(rule + (target test_mutual_adt.actual.elpi) + (action (run ./test_mutual_adt.exe %{target}))) + +(executable + (name test_mutual_adt) + (modules test_mutual_adt) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_opaque_type.actual.ml) + (deps (:pp pp.exe) (:input test_opaque_type.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_opaque_type.expected.ml test_opaque_type.actual.ml))) + +(rule + (alias runtest) + (action (diff test_opaque_type.expected.elpi test_opaque_type.actual.elpi))) + +(rule + (target test_opaque_type.actual.elpi) + (action (run ./test_opaque_type.exe %{target}))) + +(executable + (name test_opaque_type) + (modules test_opaque_type) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_poly_adt.actual.ml) + (deps (:pp pp.exe) (:input test_poly_adt.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_poly_adt.expected.ml test_poly_adt.actual.ml))) + +(rule + (alias runtest) + (action (diff test_poly_adt.expected.elpi test_poly_adt.actual.elpi))) + +(rule + (target test_poly_adt.actual.elpi) + (action (run ./test_poly_adt.exe %{target}))) + +(executable + (name test_poly_adt) + (modules test_poly_adt) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_poly_alias.actual.ml) + (deps (:pp pp.exe) (:input test_poly_alias.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_poly_alias.expected.ml test_poly_alias.actual.ml))) + +(rule + (alias runtest) + (action (diff test_poly_alias.expected.elpi test_poly_alias.actual.elpi))) + +(rule + (target test_poly_alias.actual.elpi) + (action (run ./test_poly_alias.exe %{target}))) + +(executable + (name test_poly_alias) + (modules test_poly_alias) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_simple_adt.actual.ml) + (deps (:pp pp.exe) (:input test_simple_adt.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_simple_adt.expected.ml test_simple_adt.actual.ml))) + +(rule + (alias runtest) + (action (diff test_simple_adt.expected.elpi test_simple_adt.actual.elpi))) + +(rule + (target test_simple_adt.actual.elpi) + (action (run ./test_simple_adt.exe %{target}))) + +(executable + (name test_simple_adt) + (modules test_simple_adt) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_simple_adt_record.actual.ml) + (deps (:pp pp.exe) (:input test_simple_adt_record.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_simple_adt_record.expected.ml test_simple_adt_record.actual.ml))) + +(rule + (alias runtest) + (action (diff test_simple_adt_record.expected.elpi test_simple_adt_record.actual.elpi))) + +(rule + (target test_simple_adt_record.actual.elpi) + (action (run ./test_simple_adt_record.exe %{target}))) + +(executable + (name test_simple_adt_record) + (modules test_simple_adt_record) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_simple_contextual.actual.ml) + (deps (:pp pp.exe) (:input test_simple_contextual.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_simple_contextual.expected.ml test_simple_contextual.actual.ml))) + +(rule + (alias runtest) + (action (diff test_simple_contextual.expected.elpi test_simple_contextual.actual.elpi))) + +(rule + (target test_simple_contextual.actual.elpi) + (action (run ./test_simple_contextual.exe %{target}))) + +(executable + (name test_simple_contextual) + (modules test_simple_contextual) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_simple_record.actual.ml) + (deps (:pp pp.exe) (:input test_simple_record.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_simple_record.expected.ml test_simple_record.actual.ml))) + +(rule + (alias runtest) + (action (diff test_simple_record.expected.elpi test_simple_record.actual.elpi))) + +(rule + (target test_simple_record.actual.elpi) + (action (run ./test_simple_record.exe %{target}))) + +(executable + (name test_simple_record) + (modules test_simple_record) + (preprocess (pps elpi.ppx))) + + +(rule + (targets test_two_layers_context.actual.ml) + (deps (:pp pp.exe) (:input test_two_layers_context.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_two_layers_context.expected.ml test_two_layers_context.actual.ml))) + +(rule + (alias runtest) + (action (diff test_two_layers_context.expected.elpi test_two_layers_context.actual.elpi))) + +(rule + (target test_two_layers_context.actual.elpi) + (action (run ./test_two_layers_context.exe %{target}))) + +(executable + (name test_two_layers_context) + (modules test_two_layers_context) + (preprocess (pps elpi.ppx))) + diff --git a/ppx_elpi/tests/gen_dune.ml b/ppx_elpi/tests/gen_dune.ml new file mode 100644 index 000000000..e7c620901 --- /dev/null +++ b/ppx_elpi/tests/gen_dune.ml @@ -0,0 +1,43 @@ + + +let output_stanzas filename = + let base = Filename.remove_extension filename in + Printf.printf {| +(rule + (targets %s.actual.ml) + (deps (:pp pp.exe) (:input %s.ml)) + (action (run ./%%{pp} -deriving-keep-w32 both --impl %%{input} -o %%{targets}))) + +(rule + (alias runtest) + (action (diff %s.expected.ml %s.actual.ml))) + +(rule + (alias runtest) + (action (diff %s.expected.elpi %s.actual.elpi))) + +(rule + (target %s.actual.elpi) + (action (run ./%s.exe %%{target}))) + +(executable + (name %s) + (modules %s) + (preprocess (pps elpi.ppx))) + +|} + base base base base base base base base base base + +let is_test filename = + Filename.check_suffix filename ".ml" && + not (Filename.check_suffix (Filename.remove_extension filename) ".pp") && + not (Filename.check_suffix (Filename.remove_extension filename) ".actual") && + not (Filename.check_suffix (Filename.remove_extension filename) ".expected") && + Re.Str.string_match (Re.Str.regexp_string "test_") filename 0 + +let () = + Sys.readdir "." + |> Array.to_list + |> List.sort String.compare + |> List.filter is_test + |> List.iter output_stanzas \ No newline at end of file diff --git a/ppx_elpi/tests/pp.ml b/ppx_elpi/tests/pp.ml new file mode 100644 index 000000000..e3cba4049 --- /dev/null +++ b/ppx_elpi/tests/pp.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/ppx_elpi/tests/test_alias_type.expected.elpi b/ppx_elpi/tests/test_alias_type.expected.elpi new file mode 100644 index 000000000..0d28b71bd --- /dev/null +++ b/ppx_elpi/tests/test_alias_type.expected.elpi @@ -0,0 +1,10 @@ + + +typeabbrev simple int. % simple + +pred map.simple i:simple, o:simple. +map.simple A B :- ((=) A B). + + + + diff --git a/ppx_elpi/tests/test_alias_type.expected.ml b/ppx_elpi/tests/test_alias_type.expected.ml new file mode 100644 index 000000000..448c2d3a3 --- /dev/null +++ b/ppx_elpi/tests/test_alias_type.expected.ml @@ -0,0 +1,67 @@ +let elpi_stuff = ref [] +let pp_simple _ _ = () +type simple = int[@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let rec elpi_embed_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth -> + fun h -> + fun c -> fun s -> fun t -> Elpi.API.PPX.embed_int ~depth h c s t + let rec elpi_readback_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth -> + fun h -> + fun c -> fun s -> fun t -> Elpi.API.PPX.readback_int ~depth h c s t + let simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "simple" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; ()); + pp = pp_simple; + embed = elpi_embed_simple; + readback = elpi_readback_simple + } + let elpi_simple = + Elpi.API.BuiltIn.LPCode + ("typeabbrev " ^ + ("simple" ^ + (" " ^ + (((Elpi.API.PPX.Doc.show_ty_ast ~outer:false) @@ + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty) + ^ (". % " ^ "simple"))))) + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:simple, o:simple."; + Printf.sprintf "map.%s %sA B :- %s." "simple" "" + ("(" ^ ("(=)" ^ (" " ^ ("A" ^ (" " ^ ("B" ^ ")"))))))])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_alias_type.ml b/ppx_elpi/tests/test_alias_type.ml new file mode 100644 index 000000000..7b1ab6236 --- /dev/null +++ b/ppx_elpi/tests/test_alias_type.ml @@ -0,0 +1,18 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ = () +type simple = int +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_double_contextual.expected.elpi b/ppx_elpi/tests/test_double_contextual.expected.elpi new file mode 100644 index 000000000..b0954e994 --- /dev/null +++ b/ppx_elpi/tests/test_double_contextual.expected.elpi @@ -0,0 +1,37 @@ + + +% tctx +kind tctx type. +type tentry nominal -> string -> bool -> prop. % TEntry + +% ty +kind ty type. +type tapp string -> ty -> ty. % TApp +type tall bool -> string -> (ty -> ty) -> ty. % TAll + +pred map.ty i:ty, o:ty. +map.ty (tvar A0) (tvar B0) :- ((=) A0 B0). +map.ty (tapp A0 A1) (tapp B0 B1) :- ((=) A0 B0), (map.ty A1 B1). +map.ty (tall A0 A1 A2) (tall B0 B1 B2) :- ((=) A0 B0), ((=) A1 B1), (pi x fixme x => (=) A2 B2). + + + +% ctx +kind ctx type. +type entry nominal -> string -> ty -> prop. % Entry + +% term +kind term type. +type app term -> term -> term. % App +type lam ty -> string -> (term -> term) -> term. % Lam + +pred map.term i:term, o:term. +map.term (var A0) (var B0) :- ((=) A0 B0). +map.term (app A0 A1) (app B0 B1) :- (map.term A0 B0), (map.term A1 B1). +map.term (lam A0 A1 A2) (lam B0 B1 B2) :- ((=) A0 B0), ((=) A1 B1), (pi x fixme x => (=) A2 B2). + + + + + + diff --git a/ppx_elpi/tests/test_double_contextual.expected.ml b/ppx_elpi/tests/test_double_contextual.expected.ml new file mode 100644 index 000000000..3e2b3dac4 --- /dev/null +++ b/ppx_elpi/tests/test_double_contextual.expected.ml @@ -0,0 +1,953 @@ +let elpi_stuff = ref [] +module String = + struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show = Format.asprintf "%a" pp + end +let pp_tctx _ _ = () +type tctx = + | TEntry of ((string)[@elpi.key ]) * bool [@@deriving + elpi + { + append = elpi_stuff; + index = (module String) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_tctx = "tctx" + let elpi_constant_type_tctxc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_tctx + let elpi_constant_constructor_tctx_TEntry = "tentry" + let elpi_constant_constructor_tctx_TEntryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tctx_TEntry + module Elpi_tctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_tctx_state = + Elpi.API.State.declare ~name:"tctx" + ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") + ~init:(fun () -> + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.ContextualConversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))) + let elpi_tctx_to_key ~depth:_ = + function | TEntry (elpi__1, _) -> elpi__1 + let elpi_is_tctx ~depth:elpi__depth elpi__x = + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const _ -> None + | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> + if false || (elpi__hd == elpi_constant_constructor_tctx_TEntryc) + then + (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with + | Elpi.API.RawData.Const x -> Some x + | _ -> + Elpi.API.Utils.type_error + "context entry applied to a non nominal") + else None + | _ -> None + let elpi_push_tctx ~depth:elpi__depth elpi__state elpi__name + elpi__ctx_item = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_tctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item + elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_tctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__name = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_tctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_tctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let rec elpi_embed_tctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__10, TEntry (elpi__8, elpi__9)) -> + let (elpi__state, elpi__14, elpi__11) = + Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__10 in + let (elpi__state, elpi__15, elpi__12) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__8 in + let (elpi__state, elpi__16, elpi__13) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__9 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_tctx_TEntryc + [elpi__14; elpi__15; elpi__16]), + (List.concat [elpi__11; elpi__12; elpi__13])) + let rec elpi_readback_tctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_tctx_TEntryc -> + let (elpi__state, elpi__7, elpi__6) = + Elpi.API.PPX.readback_nominal ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__2::elpi__3::[] -> + let (elpi__state, elpi__2, elpi__4) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__2 in + let (elpi__state, elpi__3, elpi__5) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__3 in + (elpi__state, + (elpi__7, (TEntry (elpi__2, elpi__3))), + (List.concat [elpi__6; elpi__4; elpi__5])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_tctx_TEntryc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "tctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let tctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "tctx" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.ContextualConversion.TyName "prop") + ~name:"tentry" ~doc:"TEntry" + ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); + embed = elpi_embed_tctx; + readback = elpi_readback_tctx + } + let in_tctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state = + let module CMap = Elpi.API.RawData.Constants.Map in + let elpi__filtered_hyps = + List.fold_left + (fun elpi__m -> + fun + ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as + elpi__hyp) + -> + match elpi_is_tctx ~depth:elpi__i elpi__hsrc with + | None -> elpi__m + | Some elpi__idx -> + (if CMap.mem elpi__idx elpi__m + then + Elpi.API.Utils.type_error + "more than one context entry for the same nominal"; + CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty + (Elpi.API.RawData.of_hyps elpi__hyps) in + let rec elpi__aux elpi__state elpi__gls elpi__i = + if elpi__i = elpi__depth + then (elpi__state, (List.concat (List.rev elpi__gls))) + else + if not (CMap.mem elpi__i elpi__filtered_hyps) + then elpi__aux elpi__state elpi__gls (elpi__i + 1) + else + (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in + let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in + let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = + tctx.Elpi.API.ContextualConversion.readback + ~depth:elpi__hyp_depth elpi__hyps elpi__constraints + elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + assert (elpi__nominal = elpi__i); + (let elpi__s = elpi_tctx_to_key ~depth:elpi__hyp_depth elpi__t in + let elpi__state = + elpi_push_tctx ~depth:elpi__i elpi__state elpi__s + { + Elpi.API.ContextualConversion.entry = elpi__t; + depth = elpi__hyp_depth + } in + elpi__aux elpi__state (elpi__gls_t :: elpi__gls) + (elpi__i + 1))) in + let elpi__state = + Elpi.API.State.set elpi_tctx_state elpi__state + (Elpi_tctx_Map.empty, CMap.empty) in + let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) + let in_tctx = in_tctx_alone + let elpi_tctx = Elpi.API.BuiltIn.MLDataC tctx + let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_tctx] @ [])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_ty _ _ = () +type ty = + | TVar of string [@elpi.var ] + | TApp of string * ty + | TAll of bool * string * + ((ty)[@elpi.binder fun b -> fun s -> TEntry (s, b)]) [@@deriving + elpi + { + append = + elpi_stuff; + context = + (() : + ty -> + tctx) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_ty = "ty" + let elpi_constant_type_tyc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ty + let elpi_constant_constructor_ty_TVar = "tvar" + let elpi_constant_constructor_ty_TVarc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TVar + let elpi_constant_constructor_ty_TApp = "tapp" + let elpi_constant_constructor_ty_TAppc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TApp + let elpi_constant_constructor_ty_TAll = "tall" + let elpi_constant_constructor_ty_TAllc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TAll + let rec elpi_embed_ty : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | TVar elpi__29 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__29 in + (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | TApp (elpi__32, elpi__33) -> + let (elpi__state, elpi__36, elpi__34) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__32 in + let (elpi__state, elpi__37, elpi__35) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__33 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ty_TAppc + [elpi__36; elpi__37]), + (List.concat [elpi__34; elpi__35])) + | TAll (elpi__38, elpi__39, elpi__40) -> + let (elpi__state, elpi__44, elpi__41) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__38 in + let (elpi__state, elpi__45, elpi__42) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__39 in + let elpi__ctx_entry = + (fun b -> fun s -> TEntry (s, b)) elpi__38 elpi__39 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__47, elpi__43) = + elpi_embed_ty ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__40 in + let elpi__46 = Elpi.API.RawData.mkLam elpi__47 in + let elpi__state = + elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ty_TAllc + [elpi__44; elpi__45; elpi__46]), + (List.concat [elpi__41; elpi__42; elpi__43])) + let rec elpi_readback_ty : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.ContextualConversion.pp_ctx_entry + pp_tctx)) elpi__dbl2ctx); + (let { + Elpi.API.ContextualConversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (TVar + (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_TAppc -> + let (elpi__state, elpi__22, elpi__21) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__19::[] -> + let (elpi__state, elpi__19, elpi__20) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__19 in + (elpi__state, (TApp (elpi__22, elpi__19)), + (List.concat [elpi__21; elpi__20])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_TAppc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_TAllc -> + let (elpi__state, elpi__28, elpi__27) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__23::elpi__24::[] -> + let (elpi__state, elpi__23, elpi__25) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__23 in + let elpi__ctx_entry = + (fun b -> fun s -> TEntry (s, b)) elpi__28 + elpi__23 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth + elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = + elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__24, elpi__26) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__24 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_ty ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (TAll (elpi__28, elpi__23, elpi__24)), + (List.concat [elpi__27; elpi__25; elpi__26])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_TAllc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ty" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let ty : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "ty" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ty"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tapp" + ~doc:"TApp" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyName + elpi_constant_type_ty]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tall" + ~doc:"TAll" + ~args:[(Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyApp + ("->", (Elpi.API.ContextualConversion.TyName "ty"), + [Elpi.API.ContextualConversion.TyName + elpi_constant_type_ty])]); + pp = pp_ty; + embed = elpi_embed_ty; + readback = elpi_readback_ty + } + let elpi_ty = Elpi.API.BuiltIn.MLDataC ty + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_ty] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.ty i:ty, o:ty."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "ty" "" + "tvar" "A0" "tvar" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "ty" "" + "tapp" "A0 A1" "tapp" "B0 B1" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + (("map." ^ elpi_constant_type_ty) ^ + (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "ty" "" + "tall" "A0 A1 A2" "tall" "B0 B1 B2" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")"))))); + Printf.sprintf "(pi x fixme x => (=) %s %s)" "A2" + "B2"]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_ctx _ _ = () +type ctx = + | Entry of ((string)[@elpi.key ]) * ty [@@deriving + elpi + { + append = elpi_stuff; + index = (module String); + context = (() : tctx) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_ctx = "ctx" + let elpi_constant_type_ctxc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ctx + let elpi_constant_constructor_ctx_Entry = "entry" + let elpi_constant_constructor_ctx_Entryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ctx_Entry + module Elpi_ctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_ctx_state = + Elpi.API.State.declare ~name:"ctx" + ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") + ~init:(fun () -> + ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant + Elpi_ctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : ctx + Elpi.API.ContextualConversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))) + let elpi_ctx_to_key ~depth:_ = + function | Entry (elpi__48, _) -> elpi__48 + let elpi_is_ctx ~depth:elpi__depth elpi__x = + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const _ -> None + | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> + if false || (elpi__hd == elpi_constant_constructor_ctx_Entryc) + then + (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with + | Elpi.API.RawData.Const x -> Some x + | _ -> + Elpi.API.Utils.type_error + "context entry applied to a non nominal") + else None + | _ -> None + let elpi_push_ctx ~depth:elpi__depth elpi__state elpi__name + elpi__ctx_item = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_ctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item + elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let elpi_pop_ctx ~depth:elpi__depth elpi__state elpi__name = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_ctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let rec elpi_embed_ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__57, Entry (elpi__55, elpi__56)) -> + let (elpi__state, elpi__61, elpi__58) = + Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__57 in + let (elpi__state, elpi__62, elpi__59) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__55 in + let (elpi__state, elpi__63, elpi__60) = + ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__56 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ctx_Entryc + [elpi__61; elpi__62; elpi__63]), + (List.concat [elpi__58; elpi__59; elpi__60])) + let rec elpi_readback_ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ctx_Entryc -> + let (elpi__state, elpi__54, elpi__53) = + Elpi.API.PPX.readback_nominal ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__49::elpi__50::[] -> + let (elpi__state, elpi__49, elpi__51) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__49 in + let (elpi__state, elpi__50, elpi__52) = + ty.Elpi.API.ContextualConversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__50 in + (elpi__state, + (elpi__54, (Entry (elpi__49, elpi__50))), + (List.concat [elpi__53; elpi__51; elpi__52])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ctx_Entryc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "ctx" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.ContextualConversion.TyName "prop") + ~name:"entry" ~doc:"Entry" + ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + ty.Elpi.API.ContextualConversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); + embed = elpi_embed_ctx; + readback = elpi_readback_ctx + } + let in_ctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state = + let module CMap = Elpi.API.RawData.Constants.Map in + let elpi__filtered_hyps = + List.fold_left + (fun elpi__m -> + fun + ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as + elpi__hyp) + -> + match elpi_is_ctx ~depth:elpi__i elpi__hsrc with + | None -> elpi__m + | Some elpi__idx -> + (if CMap.mem elpi__idx elpi__m + then + Elpi.API.Utils.type_error + "more than one context entry for the same nominal"; + CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty + (Elpi.API.RawData.of_hyps elpi__hyps) in + let rec elpi__aux elpi__state elpi__gls elpi__i = + if elpi__i = elpi__depth + then (elpi__state, (List.concat (List.rev elpi__gls))) + else + if not (CMap.mem elpi__i elpi__filtered_hyps) + then elpi__aux elpi__state elpi__gls (elpi__i + 1) + else + (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in + let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in + let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = + ctx.Elpi.API.ContextualConversion.readback + ~depth:elpi__hyp_depth elpi__hyps elpi__constraints + elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + assert (elpi__nominal = elpi__i); + (let elpi__s = elpi_ctx_to_key ~depth:elpi__hyp_depth elpi__t in + let elpi__state = + elpi_push_ctx ~depth:elpi__i elpi__state elpi__s + { + Elpi.API.ContextualConversion.entry = elpi__t; + depth = elpi__hyp_depth + } in + elpi__aux elpi__state (elpi__gls_t :: elpi__gls) + (elpi__i + 1))) in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (Elpi_ctx_Map.empty, CMap.empty) in + let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) + let in_ctx = + Elpi.API.ContextualConversion.(|+|) in_tctx_alone in_ctx_alone + let elpi_ctx = Elpi.API.BuiltIn.MLDataC ctx + let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_ctx] @ [])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_term _ _ = () +type term = + | Var of string [@elpi.var ] + | App of term * term + | Lam of ty * string * + ((term)[@elpi.binder fun b -> fun s -> Entry (s, b)]) [@@deriving + elpi + { + append = + elpi_stuff; + context = + (() : + ((ty -> tctx) + * + (term -> + ctx))) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_term = "term" + let elpi_constant_type_termc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_term + let elpi_constant_constructor_term_Var = "var" + let elpi_constant_constructor_term_Varc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Var + let elpi_constant_constructor_term_App = "app" + let elpi_constant_constructor_term_Appc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_App + let elpi_constant_constructor_term_Lam = "lam" + let elpi_constant_constructor_term_Lamc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Lam + let rec elpi_embed_term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | Var elpi__76 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__76 in + (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | App (elpi__79, elpi__80) -> + let (elpi__state, elpi__83, elpi__81) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__79 in + let (elpi__state, elpi__84, elpi__82) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__80 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Appc + [elpi__83; elpi__84]), + (List.concat [elpi__81; elpi__82])) + | Lam (elpi__85, elpi__86, elpi__87) -> + let (elpi__state, elpi__91, elpi__88) = + ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__85 in + let (elpi__state, elpi__92, elpi__89) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__86 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__85 elpi__86 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__94, elpi__90) = + elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__87 in + let elpi__93 = Elpi.API.RawData.mkLam elpi__94 in + let elpi__state = + elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Lamc + [elpi__91; elpi__92; elpi__93]), + (List.concat [elpi__88; elpi__89; elpi__90])) + let rec elpi_readback_term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.ContextualConversion.pp_ctx_entry + pp_ctx)) elpi__dbl2ctx); + (let { + Elpi.API.ContextualConversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (Var (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Appc -> + let (elpi__state, elpi__69, elpi__68) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__66::[] -> + let (elpi__state, elpi__66, elpi__67) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__66 in + (elpi__state, (App (elpi__69, elpi__66)), + (List.concat [elpi__68; elpi__67])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Appc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Lamc -> + let (elpi__state, elpi__75, elpi__74) = + ty.Elpi.API.ContextualConversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | elpi__70::elpi__71::[] -> + let (elpi__state, elpi__70, elpi__72) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__70 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__75 elpi__70 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = + elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__71, elpi__73) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__71 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_term ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (Lam (elpi__75, elpi__70, elpi__71)), + (List.concat [elpi__74; elpi__72; elpi__73])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Lamc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "term" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"app" + ~doc:"App" + ~args:[Elpi.API.ContextualConversion.TyName + elpi_constant_type_term; + Elpi.API.ContextualConversion.TyName + elpi_constant_type_term]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" + ~doc:"Lam" + ~args:[ty.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyApp + ("->", + (Elpi.API.ContextualConversion.TyName "term"), + [Elpi.API.ContextualConversion.TyName + elpi_constant_type_term])]); + pp = pp_term; + embed = elpi_embed_term; + readback = elpi_readback_term + } + let elpi_term = Elpi.API.BuiltIn.MLDataC term + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_term] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.term i:term, o:term."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" + "" "var" "A0" "var" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" + "" "app" "A0 A1" "app" "B0 B1" + (String.concat ", " + ["(" ^ + (("map." ^ elpi_constant_type_term) ^ + (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + (("map." ^ elpi_constant_type_term) ^ + (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" + "" "lam" "A0 A1 A2" "lam" "B0 B1 B2" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")"))))); + Printf.sprintf "(pi x fixme x => (=) %s %s)" "A2" + "B2"]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let in_ctx + : ((tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx + ContextualConversion.ctx_entry RawData.Constants.Map.t), + Data.constraints) ContextualConversion.ctx_readback + = in_ctx +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_double_contextual.ml b/ppx_elpi/tests/test_double_contextual.ml new file mode 100644 index 000000000..e5201fff9 --- /dev/null +++ b/ppx_elpi/tests/test_double_contextual.ml @@ -0,0 +1,45 @@ +let elpi_stuff = ref [] + +module String = struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show = Format.asprintf "%a" pp +end + +let pp_tctx _ _ = () +type tctx = TEntry of (string[@elpi.key]) * bool +[@@deriving elpi { append = elpi_stuff; index = (module String) }] + +let pp_ty _ _ = () +type ty = + | TVar of string [@elpi.var] + | TApp of string * ty + | TAll of bool * string * (ty[@elpi.binder (fun b s -> TEntry(s,b))]) +[@@deriving elpi { append = elpi_stuff; context = (() : ty -> tctx) }] + + +let pp_ctx _ _ = () +type ctx = Entry of (string[@elpi.key]) * ty +[@@deriving elpi { append = elpi_stuff; index = (module String); context = (() : tctx) } ] + +let pp_term _ _ = () +type term = + | Var of string [@elpi.var] + | App of term * term + | Lam of ty * string * (term[@elpi.binder (fun b s -> Entry(s,b))]) +[@@deriving elpi { append = elpi_stuff; context = (() : (ty -> tctx) * (term -> ctx)) }] + +open Elpi.API + +let in_ctx : (tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx ContextualConversion.ctx_entry RawData.Constants.Map.t, Data.constraints) ContextualConversion.ctx_readback = in_ctx + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_mutual_adt.expected.elpi b/ppx_elpi/tests/test_mutual_adt.expected.elpi new file mode 100644 index 000000000..0ed87d886 --- /dev/null +++ b/ppx_elpi/tests/test_mutual_adt.expected.elpi @@ -0,0 +1,27 @@ + + +% simple +kind simple type. +type a simple. % A +type b int -> mut -> simple. % B + +% mut +kind mut type. +type c mut. % C +type d simple -> mut. % D + +pred map.simple i:simple, o:simple. +map.simple a a. +map.simple (b A0 A1) (b B0 B1) :- ((=) A0 B0), (map.mut A1 B1). + + + +pred map.mut i:mut, o:mut. +map.mut c c. +map.mut (d A0) (d B0) :- (map.simple A0 B0). + + + + + + diff --git a/ppx_elpi/tests/test_mutual_adt.expected.ml b/ppx_elpi/tests/test_mutual_adt.expected.ml new file mode 100644 index 000000000..30ec22fdc --- /dev/null +++ b/ppx_elpi/tests/test_mutual_adt.expected.ml @@ -0,0 +1,232 @@ +let elpi_stuff = ref [] +let pp_simple _ _ = () +let pp_mut _ _ = () +type simple = + | A + | B of int * mut +and mut = + | C + | D of simple [@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let elpi_constant_constructor_simple_A = "a" + let elpi_constant_constructor_simple_Ac = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_A + let elpi_constant_constructor_simple_B = "b" + let elpi_constant_constructor_simple_Bc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_B + let elpi_constant_type_mut = "mut" + let elpi_constant_type_mutc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_mut + let elpi_constant_constructor_mut_C = "c" + let elpi_constant_constructor_mut_Cc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_mut_C + let elpi_constant_constructor_mut_D = "d" + let elpi_constant_constructor_mut_Dc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_mut_D + let rec elpi_embed_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | A -> + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Ac []), + (List.concat [])) + | B (elpi__5, elpi__6) -> + let (elpi__state, elpi__9, elpi__7) = + Elpi.API.PPX.embed_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__5 in + let (elpi__state, elpi__10, elpi__8) = + elpi_embed_mut ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__6 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Bc + [elpi__9; elpi__10]), + (List.concat [elpi__7; elpi__8])) + and elpi_embed_mut : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (mut, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | C -> + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_mut_Cc + []), (List.concat [])) + | D elpi__13 -> + let (elpi__state, elpi__15, elpi__14) = + elpi_embed_simple ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__13 in + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_mut_Dc + [elpi__15]), (List.concat [elpi__14])) + let rec elpi_readback_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when + elpi__hd == elpi_constant_constructor_simple_Ac -> + (elpi__state, A, []) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_Bc -> + let (elpi__state, elpi__4, elpi__3) = + Elpi.API.PPX.readback_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__1::[] -> + let (elpi__state, elpi__1, elpi__2) = + elpi_readback_mut ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__1 in + (elpi__state, (B (elpi__4, elpi__1)), + (List.concat [elpi__3; elpi__2])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_Bc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) + and elpi_readback_mut : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (mut, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when + elpi__hd == elpi_constant_constructor_mut_Cc -> + (elpi__state, C, []) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_mut_Dc -> + let (elpi__state, elpi__12, elpi__11) = + elpi_readback_simple ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (D elpi__12), + (List.concat [elpi__11])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_mut_Dc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "mut" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "simple" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"a" ~doc:"A" + ~args:[]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"b" ~doc:"B" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyName + elpi_constant_type_mut]); + pp = pp_simple; + embed = elpi_embed_simple; + readback = elpi_readback_simple + } + let mut : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (mut, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "mut" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"mut"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"c" ~doc:"C" + ~args:[]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"d" ~doc:"D" + ~args:[Elpi.API.ContextualConversion.TyName + elpi_constant_type_simple]); + pp = pp_mut; + embed = elpi_embed_mut; + readback = elpi_readback_mut + } + let elpi_simple = Elpi.API.BuiltIn.MLDataC simple + let elpi_mut = Elpi.API.BuiltIn.MLDataC mut + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple; elpi_mut] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:simple, o:simple."; + "map.simple a a."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "" "b" "A0 A1" "b" "B0 B1" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + (("map." ^ elpi_constant_type_mut) ^ + (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + "\n"]); + Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.mut i:mut, o:mut."; + "map.mut c c."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "mut" "" + "d" "A0" "d" "B0" + (String.concat ", " + ["(" ^ + (("map." ^ elpi_constant_type_simple) ^ + (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_mutual_adt.ml b/ppx_elpi/tests/test_mutual_adt.ml new file mode 100644 index 000000000..bb3fa4331 --- /dev/null +++ b/ppx_elpi/tests/test_mutual_adt.ml @@ -0,0 +1,20 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ = () +let pp_mut _ _ = () +type simple = A | B of int * mut +and mut = C | D of simple +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_opaque_type.expected.elpi b/ppx_elpi/tests/test_opaque_type.expected.elpi new file mode 100644 index 000000000..8bff7f9d1 --- /dev/null +++ b/ppx_elpi/tests/test_opaque_type.expected.elpi @@ -0,0 +1,8 @@ + + +typeabbrev simple (ctype "simple"). + + + + + diff --git a/ppx_elpi/tests/test_opaque_type.expected.ml b/ppx_elpi/tests/test_opaque_type.expected.ml new file mode 100644 index 000000000..1806fc2d6 --- /dev/null +++ b/ppx_elpi/tests/test_opaque_type.expected.ml @@ -0,0 +1,43 @@ +let elpi_stuff = ref [] +let pp_simple _ _ = () +type simple[@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let (simple : simple Elpi.API.Conversion.t) = + Elpi.API.OpaqueData.declare + { + Elpi.API.OpaqueData.name = "simple"; + doc = ""; + pp = pp_simple; + compare = Pervasives.compare; + hash = Hashtbl.hash; + hconsed = false; + constants = [] + } + let elpi_embed_simple ~depth _ _ s t = + simple.Elpi.API.Conversion.embed ~depth s t + let elpi_readback_simple ~depth _ _ s t = + simple.Elpi.API.Conversion.readback ~depth s t + let elpi_simple = Elpi.API.BuiltIn.MLData simple + let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_simple] @ [])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +[@@@warning "-26-27-32-39-60"] +let rec test : type h c. + depth:int -> + h -> + c -> + State.t -> + RawData.term -> (State.t * simple * Conversion.extra_goals) + = elpi_readback_simple +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_opaque_type.ml b/ppx_elpi/tests/test_opaque_type.ml new file mode 100644 index 000000000..ddc9b8783 --- /dev/null +++ b/ppx_elpi/tests/test_opaque_type.ml @@ -0,0 +1,22 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ = () +type simple +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +[@@@warning "-26-27-32-39-60"] +let rec test : type h c . depth:int -> h -> c -> State.t -> RawData.term -> State.t * simple * Conversion.extra_goals = + elpi_readback_simple + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_poly_adt.expected.elpi b/ppx_elpi/tests/test_poly_adt.expected.elpi new file mode 100644 index 000000000..1c1eacf0b --- /dev/null +++ b/ppx_elpi/tests/test_poly_adt.expected.elpi @@ -0,0 +1,18 @@ + + +% simple +kind simple type -> type. +type a simple A0. % A +type b int -> simple A0. % B +type c A0 -> int -> simple A0. % C + +pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0. +map.simple F0 a a. +map.simple F0 (b A0) (b B0) :- ((=) A0 B0). +map.simple F0 (c A0 A1) (c B0 B1) :- (F0 A0 B0), ((=) A1 B1). + + + + + + diff --git a/ppx_elpi/tests/test_poly_adt.expected.ml b/ppx_elpi/tests/test_poly_adt.expected.ml new file mode 100644 index 000000000..d61cbab51 --- /dev/null +++ b/ppx_elpi/tests/test_poly_adt.expected.ml @@ -0,0 +1,189 @@ +let elpi_stuff = ref [] +let pp_simple _ _ _ = () +type 'a simple = + | A + | B of int + | C of 'a * int [@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let elpi_constant_constructor_simple_A = "a" + let elpi_constant_constructor_simple_Ac = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_A + let elpi_constant_constructor_simple_B = "b" + let elpi_constant_constructor_simple_Bc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_B + let elpi_constant_constructor_simple_C = "c" + let elpi_constant_constructor_simple_Cc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_C + let rec elpi_embed_simple : + 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding -> + ('elpi__param__a simple, 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun elpi_embed_elpi__param__a -> + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | A -> + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Ac []), + (List.concat [])) + | B elpi__7 -> + let (elpi__state, elpi__9, elpi__8) = + Elpi.API.PPX.embed_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__7 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Bc [elpi__9]), + (List.concat [elpi__8])) + | C (elpi__10, elpi__11) -> + let (elpi__state, elpi__14, elpi__12) = + elpi_embed_elpi__param__a ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__10 in + let (elpi__state, elpi__15, elpi__13) = + Elpi.API.PPX.embed_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__11 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Cc + [elpi__14; elpi__15]), + (List.concat [elpi__12; elpi__13])) + let rec elpi_readback_simple : + 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback -> + ('elpi__param__a simple, 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun elpi_readback_elpi__param__a -> + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when + elpi__hd == elpi_constant_constructor_simple_Ac -> + (elpi__state, A, []) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_Bc -> + let (elpi__state, elpi__2, elpi__1) = + Elpi.API.PPX.readback_int ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (B elpi__2), + (List.concat [elpi__1])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_Bc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_Cc -> + let (elpi__state, elpi__6, elpi__5) = + elpi_readback_elpi__param__a ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__3::[] -> + let (elpi__state, elpi__3, elpi__4) = + Elpi.API.PPX.readback_int ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__3 in + (elpi__state, (C (elpi__6, elpi__3)), + (List.concat [elpi__5; elpi__4])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_Cc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let simple : + 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t -> + ('elpi__param__a simple, 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + fun elpi__param__a -> + let kind = + Elpi.API.ContextualConversion.TyApp + ("simple", (elpi__param__a.Elpi.API.ContextualConversion.ty), []) in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; + (Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"a" + ~doc:"A" ~args:[]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"b" + ~doc:"B" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty]); + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"c" ~doc:"C" + ~args:[elpi__param__a.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty]); + pp = (pp_simple elpi__param__a.pp); + embed = + (elpi_embed_simple + elpi__param__a.Elpi.API.ContextualConversion.embed); + readback = + (elpi_readback_simple + elpi__param__a.Elpi.API.ContextualConversion.readback) + } + let elpi_simple = + Elpi.API.BuiltIn.MLDataC + (simple + (Elpi.API.ContextualConversion.(!>) @@ + (Elpi.API.BuiltInData.poly "A0"))) + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0."; + "map.simple F0 a a."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "F0 " "b" "A0" "b" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "F0 " "c" "A0 A1" "c" "B0 B1" + (String.concat ", " + ["(" ^ + ("F0" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let _ = + simple @@ (Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.int) +let _ = + simple @@ (Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.float) +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_poly_adt.ml b/ppx_elpi/tests/test_poly_adt.ml new file mode 100644 index 000000000..048fa01b3 --- /dev/null +++ b/ppx_elpi/tests/test_poly_adt.ml @@ -0,0 +1,21 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ _ = () +type 'a simple = A | B of int | C of 'a * int +[@@deriving elpi { append = elpi_stuff } ] + +let _ = simple @@ Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.int +let _ = simple @@ Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.float + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_poly_alias.expected.elpi b/ppx_elpi/tests/test_poly_alias.expected.elpi new file mode 100644 index 000000000..5bf826301 --- /dev/null +++ b/ppx_elpi/tests/test_poly_alias.expected.elpi @@ -0,0 +1,10 @@ + + +typeabbrev (simple A0) (pair A0 int). % simple + +pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0. +map.simple F0 A B :- ((ppx.map.pair F0 (=)) A B). + + + + diff --git a/ppx_elpi/tests/test_poly_alias.expected.ml b/ppx_elpi/tests/test_poly_alias.expected.ml new file mode 100644 index 000000000..95895145c --- /dev/null +++ b/ppx_elpi/tests/test_poly_alias.expected.ml @@ -0,0 +1,98 @@ +let elpi_stuff = ref [] +let pp_simple _ _ _ = () +type 'a simple = ('a * int)[@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let rec elpi_embed_simple : + 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding -> + ('elpi__param__a simple, 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun elpi_embed_elpi__param__a -> + fun ~depth -> + fun h -> + fun c -> + fun s -> + fun t -> + (Elpi.Builtin.PPX.embed_pair elpi_embed_elpi__param__a + Elpi.API.PPX.embed_int) ~depth h c s t + let rec elpi_readback_simple : + 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback -> + ('elpi__param__a simple, 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun elpi_readback_elpi__param__a -> + fun ~depth -> + fun h -> + fun c -> + fun s -> + fun t -> + (Elpi.Builtin.PPX.readback_pair + elpi_readback_elpi__param__a Elpi.API.PPX.readback_int) + ~depth h c s t + let simple : + 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t -> + ('elpi__param__a simple, 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + fun elpi__param__a -> + let kind = + Elpi.API.ContextualConversion.TyApp + ("simple", (elpi__param__a.Elpi.API.ContextualConversion.ty), []) in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; ()); + pp = (pp_simple elpi__param__a.pp); + embed = + (elpi_embed_simple + elpi__param__a.Elpi.API.ContextualConversion.embed); + readback = + (elpi_readback_simple + elpi__param__a.Elpi.API.ContextualConversion.readback) + } + let elpi_simple = + let elpi__param__a = + Elpi.API.ContextualConversion.(!>) @@ + (Elpi.API.BuiltInData.poly (Printf.sprintf "A%d" 0)) in + Elpi.API.BuiltIn.LPCode + ("typeabbrev " ^ + (("(" ^ ("simple" ^ (" " ^ ("A0" ^ ")")))) ^ + (" " ^ + (((Elpi.API.PPX.Doc.show_ty_ast ~outer:false) @@ + (Elpi.API.ContextualConversion.(!>>>) Elpi.Builtin.pair + elpi__param__a + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int)).Elpi.API.ContextualConversion.ty) + ^ (". % " ^ "simple"))))) + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0."; + Printf.sprintf "map.%s %sA B :- %s." "simple" "F0 " + ("(" ^ + ((Printf.sprintf "(ppx.map.pair %s %s)" "F0" "(=)") + ^ (" " ^ ("A" ^ (" " ^ ("B" ^ ")"))))))])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_poly_alias.ml b/ppx_elpi/tests/test_poly_alias.ml new file mode 100644 index 000000000..36c5bb745 --- /dev/null +++ b/ppx_elpi/tests/test_poly_alias.ml @@ -0,0 +1,18 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ _ = () +type 'a simple = 'a * int +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_ppx.mli b/ppx_elpi/tests/test_ppx.mli new file mode 100644 index 000000000..e69de29bb diff --git a/ppx_elpi/tests/test_simple_adt.expected.elpi b/ppx_elpi/tests/test_simple_adt.expected.elpi new file mode 100644 index 000000000..4372d70a1 --- /dev/null +++ b/ppx_elpi/tests/test_simple_adt.expected.elpi @@ -0,0 +1,16 @@ + + +% simple +kind simple type. +type a simple. % A +type b int -> simple. % B + +pred map.simple i:simple, o:simple. +map.simple a a. +map.simple (b A0) (b B0) :- ((=) A0 B0). + + + + + + diff --git a/ppx_elpi/tests/test_simple_adt.expected.ml b/ppx_elpi/tests/test_simple_adt.expected.ml new file mode 100644 index 000000000..a934f7724 --- /dev/null +++ b/ppx_elpi/tests/test_simple_adt.expected.ml @@ -0,0 +1,118 @@ +let elpi_stuff = ref [] +let pp_simple _ _ = () +type simple = + | A + | B of int [@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let elpi_constant_constructor_simple_A = "a" + let elpi_constant_constructor_simple_Ac = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_A + let elpi_constant_constructor_simple_B = "b" + let elpi_constant_constructor_simple_Bc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_B + let rec elpi_embed_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | A -> + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Ac []), + (List.concat [])) + | B elpi__3 -> + let (elpi__state, elpi__5, elpi__4) = + Elpi.API.PPX.embed_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__3 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_Bc [elpi__5]), + (List.concat [elpi__4])) + let rec elpi_readback_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when + elpi__hd == elpi_constant_constructor_simple_Ac -> + (elpi__state, A, []) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_Bc -> + let (elpi__state, elpi__2, elpi__1) = + Elpi.API.PPX.readback_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (B elpi__2), (List.concat [elpi__1])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_Bc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "simple" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"a" ~doc:"A" + ~args:[]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"b" ~doc:"B" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty]); + pp = pp_simple; + embed = elpi_embed_simple; + readback = elpi_readback_simple + } + let elpi_simple = Elpi.API.BuiltIn.MLDataC simple + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:simple, o:simple."; + "map.simple a a."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "" "b" "A0" "b" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_simple_adt.ml b/ppx_elpi/tests/test_simple_adt.ml new file mode 100644 index 000000000..94be901bb --- /dev/null +++ b/ppx_elpi/tests/test_simple_adt.ml @@ -0,0 +1,18 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ = () +type simple = A | B of int +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_simple_adt_record.expected.elpi b/ppx_elpi/tests/test_simple_adt_record.expected.elpi new file mode 100644 index 000000000..06a020926 --- /dev/null +++ b/ppx_elpi/tests/test_simple_adt_record.expected.elpi @@ -0,0 +1,16 @@ + + +% simple +kind simple type. +type k1 int -> bool -> simple. % K1 +type k2 bool -> simple. % K2 + +pred map.simple i:simple, o:simple. +map.simple (k1 A0 A1) (k1 B0 B1) :- ((=) A0 B0), ((=) A1 B1). +map.simple (k2 A0) (k2 B0) :- ((=) A0 B0). + + + + + + diff --git a/ppx_elpi/tests/test_simple_adt_record.expected.ml b/ppx_elpi/tests/test_simple_adt_record.expected.ml new file mode 100644 index 000000000..c2a275f6f --- /dev/null +++ b/ppx_elpi/tests/test_simple_adt_record.expected.ml @@ -0,0 +1,150 @@ +let elpi_stuff = ref [] +let pp_simple _ _ = () +type simple = + | K1 of { + f: int ; + g: bool } + | K2 of { + f2: bool } [@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let elpi_constant_constructor_simple_K1 = "k1" + let elpi_constant_constructor_simple_K1c = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_K1 + let elpi_constant_constructor_simple_K2 = "k2" + let elpi_constant_constructor_simple_K2c = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_K2 + let rec elpi_embed_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | K1 { f = elpi__7; g = elpi__8 } -> + let (elpi__state, elpi__11, elpi__9) = + Elpi.API.PPX.embed_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__7 in + let (elpi__state, elpi__12, elpi__10) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__8 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_K1c + [elpi__11; elpi__12]), + (List.concat [elpi__9; elpi__10])) + | K2 { f2 = elpi__13 } -> + let (elpi__state, elpi__15, elpi__14) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__13 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_K2c [elpi__15]), + (List.concat [elpi__14])) + let rec elpi_readback_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_K1c -> + let (elpi__state, elpi__4, elpi__3) = + Elpi.API.PPX.readback_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__1::[] -> + let (elpi__state, elpi__1, elpi__2) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__1 in + (elpi__state, (K1 { f = elpi__4; g = elpi__1 }), + (List.concat [elpi__3; elpi__2])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_K1c))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_K2c -> + let (elpi__state, elpi__6, elpi__5) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (K2 { f2 = elpi__6 }), + (List.concat [elpi__5])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_K2c))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "simple" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"k1" ~doc:"K1" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"k2" ~doc:"K2" + ~args:[(Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + pp = pp_simple; + embed = elpi_embed_simple; + readback = elpi_readback_simple + } + let elpi_simple = Elpi.API.BuiltIn.MLDataC simple + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:simple, o:simple."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "" "k1" "A0 A1" "k1" "B0 B1" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "" "k2" "A0" "k2" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_simple_adt_record.ml b/ppx_elpi/tests/test_simple_adt_record.ml new file mode 100644 index 000000000..dc8b91bb4 --- /dev/null +++ b/ppx_elpi/tests/test_simple_adt_record.ml @@ -0,0 +1,18 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ = () +type simple = K1 of { f : int; g : bool } | K2 of { f2 : bool } +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_simple_contextual.expected.elpi b/ppx_elpi/tests/test_simple_contextual.expected.elpi new file mode 100644 index 000000000..6007bbcd6 --- /dev/null +++ b/ppx_elpi/tests/test_simple_contextual.expected.elpi @@ -0,0 +1,21 @@ + + +% ctx +kind ctx type. +type entry nominal -> string -> bool -> prop. % Entry + +% term +kind term type. +type app term -> term -> term. % App +type lam bool -> string -> (term -> term) -> term. % Lam + +pred map.term i:term, o:term. +map.term (var A0) (var B0) :- ((=) A0 B0). +map.term (app A0 A1) (app B0 B1) :- (map.term A0 B0), (map.term A1 B1). +map.term (lam A0 A1 A2) (lam B0 B1 B2) :- ((=) A0 B0), ((=) A1 B1), (pi x fixme x => (=) A2 B2). + + + + + + diff --git a/ppx_elpi/tests/test_simple_contextual.expected.ml b/ppx_elpi/tests/test_simple_contextual.expected.ml new file mode 100644 index 000000000..0c397e927 --- /dev/null +++ b/ppx_elpi/tests/test_simple_contextual.expected.ml @@ -0,0 +1,475 @@ +let elpi_stuff = ref [] +module String = + struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show = Format.asprintf "%a" pp + end +let pp_ctx _ _ = () +type ctx = + | Entry of ((string)[@elpi.key ]) * bool [@@deriving + elpi + { + append = elpi_stuff; + index = (module String) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_ctx = "ctx" + let elpi_constant_type_ctxc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ctx + let elpi_constant_constructor_ctx_Entry = "entry" + let elpi_constant_constructor_ctx_Entryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ctx_Entry + module Elpi_ctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_ctx_state = + Elpi.API.State.declare ~name:"ctx" + ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") + ~init:(fun () -> + ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant + Elpi_ctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : ctx + Elpi.API.ContextualConversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))) + let elpi_ctx_to_key ~depth:_ = function | Entry (elpi__1, _) -> elpi__1 + let elpi_is_ctx ~depth:elpi__depth elpi__x = + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const _ -> None + | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> + if false || (elpi__hd == elpi_constant_constructor_ctx_Entryc) + then + (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with + | Elpi.API.RawData.Const x -> Some x + | _ -> + Elpi.API.Utils.type_error + "context entry applied to a non nominal") + else None + | _ -> None + let elpi_push_ctx ~depth:elpi__depth elpi__state elpi__name + elpi__ctx_item = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_ctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item + elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let elpi_pop_ctx ~depth:elpi__depth elpi__state elpi__name = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_ctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let rec elpi_embed_ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__10, Entry (elpi__8, elpi__9)) -> + let (elpi__state, elpi__14, elpi__11) = + Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__10 in + let (elpi__state, elpi__15, elpi__12) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__8 in + let (elpi__state, elpi__16, elpi__13) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__9 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ctx_Entryc + [elpi__14; elpi__15; elpi__16]), + (List.concat [elpi__11; elpi__12; elpi__13])) + let rec elpi_readback_ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ctx_Entryc -> + let (elpi__state, elpi__7, elpi__6) = + Elpi.API.PPX.readback_nominal ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__2::elpi__3::[] -> + let (elpi__state, elpi__2, elpi__4) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__2 in + let (elpi__state, elpi__3, elpi__5) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__3 in + (elpi__state, (elpi__7, (Entry (elpi__2, elpi__3))), + (List.concat [elpi__6; elpi__4; elpi__5])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ctx_Entryc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "ctx" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.ContextualConversion.TyName "prop") + ~name:"entry" ~doc:"Entry" + ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); + embed = elpi_embed_ctx; + readback = elpi_readback_ctx + } + let in_ctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state = + let module CMap = Elpi.API.RawData.Constants.Map in + let elpi__filtered_hyps = + List.fold_left + (fun elpi__m -> + fun + ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as + elpi__hyp) + -> + match elpi_is_ctx ~depth:elpi__i elpi__hsrc with + | None -> elpi__m + | Some elpi__idx -> + (if CMap.mem elpi__idx elpi__m + then + Elpi.API.Utils.type_error + "more than one context entry for the same nominal"; + CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty + (Elpi.API.RawData.of_hyps elpi__hyps) in + let rec elpi__aux elpi__state elpi__gls elpi__i = + if elpi__i = elpi__depth + then (elpi__state, (List.concat (List.rev elpi__gls))) + else + if not (CMap.mem elpi__i elpi__filtered_hyps) + then elpi__aux elpi__state elpi__gls (elpi__i + 1) + else + (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in + let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in + let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = + ctx.Elpi.API.ContextualConversion.readback + ~depth:elpi__hyp_depth elpi__hyps elpi__constraints + elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + assert (elpi__nominal = elpi__i); + (let elpi__s = elpi_ctx_to_key ~depth:elpi__hyp_depth elpi__t in + let elpi__state = + elpi_push_ctx ~depth:elpi__i elpi__state elpi__s + { + Elpi.API.ContextualConversion.entry = elpi__t; + depth = elpi__hyp_depth + } in + elpi__aux elpi__state (elpi__gls_t :: elpi__gls) + (elpi__i + 1))) in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (Elpi_ctx_Map.empty, CMap.empty) in + let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) + let in_ctx = in_ctx_alone + let elpi_ctx = Elpi.API.BuiltIn.MLDataC ctx + let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_ctx] @ [])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_term _ _ = () +type term = + | Var of string [@elpi.var ] + | App of term * term + | Lam of bool * string * + ((term)[@elpi.binder fun b -> fun s -> Entry (s, b)]) [@@deriving + elpi + { + append = + elpi_stuff; + context = + (() : + term -> + ctx) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_term = "term" + let elpi_constant_type_termc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_term + let elpi_constant_constructor_term_Var = "var" + let elpi_constant_constructor_term_Varc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Var + let elpi_constant_constructor_term_App = "app" + let elpi_constant_constructor_term_Appc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_App + let elpi_constant_constructor_term_Lam = "lam" + let elpi_constant_constructor_term_Lamc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Lam + let rec elpi_embed_term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | Var elpi__29 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__29 in + (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | App (elpi__32, elpi__33) -> + let (elpi__state, elpi__36, elpi__34) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__32 in + let (elpi__state, elpi__37, elpi__35) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__33 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Appc + [elpi__36; elpi__37]), + (List.concat [elpi__34; elpi__35])) + | Lam (elpi__38, elpi__39, elpi__40) -> + let (elpi__state, elpi__44, elpi__41) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__38 in + let (elpi__state, elpi__45, elpi__42) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__39 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__38 elpi__39 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__47, elpi__43) = + elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__40 in + let elpi__46 = Elpi.API.RawData.mkLam elpi__47 in + let elpi__state = + elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Lamc + [elpi__44; elpi__45; elpi__46]), + (List.concat [elpi__41; elpi__42; elpi__43])) + let rec elpi_readback_term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.ContextualConversion.pp_ctx_entry + pp_ctx)) elpi__dbl2ctx); + (let { + Elpi.API.ContextualConversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (Var (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Appc -> + let (elpi__state, elpi__22, elpi__21) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__19::[] -> + let (elpi__state, elpi__19, elpi__20) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__19 in + (elpi__state, (App (elpi__22, elpi__19)), + (List.concat [elpi__21; elpi__20])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Appc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Lamc -> + let (elpi__state, elpi__28, elpi__27) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__23::elpi__24::[] -> + let (elpi__state, elpi__23, elpi__25) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__23 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__28 elpi__23 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = + elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__24, elpi__26) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__24 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_term ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (Lam (elpi__28, elpi__23, elpi__24)), + (List.concat [elpi__27; elpi__25; elpi__26])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Lamc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "term" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"app" + ~doc:"App" + ~args:[Elpi.API.ContextualConversion.TyName + elpi_constant_type_term; + Elpi.API.ContextualConversion.TyName + elpi_constant_type_term]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" + ~doc:"Lam" + ~args:[(Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyApp + ("->", + (Elpi.API.ContextualConversion.TyName "term"), + [Elpi.API.ContextualConversion.TyName + elpi_constant_type_term])]); + pp = pp_term; + embed = elpi_embed_term; + readback = elpi_readback_term + } + let elpi_term = Elpi.API.BuiltIn.MLDataC term + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_term] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.term i:term, o:term."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" + "" "var" "A0" "var" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" + "" "app" "A0 A1" "app" "B0 B1" + (String.concat ", " + ["(" ^ + (("map." ^ elpi_constant_type_term) ^ + (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + (("map." ^ elpi_constant_type_term) ^ + (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" + "" "lam" "A0 A1 A2" "lam" "B0 B1 B2" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")"))))); + Printf.sprintf "(pi x fixme x => (=) %s %s)" "A2" + "B2"]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_simple_contextual.ml b/ppx_elpi/tests/test_simple_contextual.ml new file mode 100644 index 000000000..508f8d587 --- /dev/null +++ b/ppx_elpi/tests/test_simple_contextual.ml @@ -0,0 +1,31 @@ +let elpi_stuff = ref [] + +module String = struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show = Format.asprintf "%a" pp +end + +let pp_ctx _ _ = () +type ctx = Entry of (string[@elpi.key]) * bool +[@@deriving elpi { append = elpi_stuff; index = (module String) }] + +let pp_term _ _ = () +type term = + | Var of string [@elpi.var] + | App of term * term + | Lam of bool * string * (term[@elpi.binder (fun b s -> Entry(s,b))]) +[@@deriving elpi { append = elpi_stuff; context = (() : term -> ctx) }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_simple_record.expected.elpi b/ppx_elpi/tests/test_simple_record.expected.elpi new file mode 100644 index 000000000..a8ab141dc --- /dev/null +++ b/ppx_elpi/tests/test_simple_record.expected.elpi @@ -0,0 +1,14 @@ + + +% simple +kind simple type. +type simple int -> bool -> simple. % simple + +pred map.simple i:simple, o:simple. +map.simple (simple A0 A1) (simple B0 B1) :- ((=) A0 B0), ((=) A1 B1). + + + + + + diff --git a/ppx_elpi/tests/test_simple_record.expected.ml b/ppx_elpi/tests/test_simple_record.expected.ml new file mode 100644 index 000000000..4baa031c5 --- /dev/null +++ b/ppx_elpi/tests/test_simple_record.expected.ml @@ -0,0 +1,115 @@ +let elpi_stuff = ref [] +let pp_simple _ _ = () +type simple = { + f: int ; + g: bool }[@@deriving elpi { append = elpi_stuff }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_simple = "simple" + let elpi_constant_type_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_simple + let elpi_constant_constructor_simple_simple = "simple" + let elpi_constant_constructor_simple_simplec = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_simple_simple + let rec elpi_embed_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | { f = elpi__5; g = elpi__6 } -> + let (elpi__state, elpi__9, elpi__7) = + Elpi.API.PPX.embed_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__5 in + let (elpi__state, elpi__10, elpi__8) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__6 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_simple_simplec + [elpi__9; elpi__10]), + (List.concat [elpi__7; elpi__8])) + let rec elpi_readback_simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_simple_simplec -> + let (elpi__state, elpi__4, elpi__3) = + Elpi.API.PPX.readback_int ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__1::[] -> + let (elpi__state, elpi__1, elpi__2) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__1 in + (elpi__state, { f = elpi__4; g = elpi__1 }, + (List.concat [elpi__3; elpi__2])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_simple_simplec))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let simple : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "simple" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"simple" + ~doc:"simple" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + pp = pp_simple; + embed = elpi_embed_simple; + readback = elpi_readback_simple + } + let elpi_simple = Elpi.API.BuiltIn.MLDataC simple + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_simple] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.simple i:simple, o:simple."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" + "" "simple" "A0 A1" "simple" "B0 B1" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_simple_record.ml b/ppx_elpi/tests/test_simple_record.ml new file mode 100644 index 000000000..f3f009246 --- /dev/null +++ b/ppx_elpi/tests/test_simple_record.ml @@ -0,0 +1,18 @@ +let elpi_stuff = ref [] + +let pp_simple _ _ = () +type simple = { f : int; g : bool } +[@@deriving elpi { append = elpi_stuff }] + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !elpi_stuff + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () \ No newline at end of file diff --git a/ppx_elpi/tests/test_two_layers_context.expected.elpi b/ppx_elpi/tests/test_two_layers_context.expected.elpi new file mode 100644 index 000000000..99e20ca84 --- /dev/null +++ b/ppx_elpi/tests/test_two_layers_context.expected.elpi @@ -0,0 +1,5 @@ +{{ c4 -> { Data.ContextualConversion.entry = ; depth = 5 }; }} +{{ c0 -> { Data.ContextualConversion.entry = ; depth = 5 }; c2 -> + { Data.ContextualConversion.entry = ; depth = 5 }; }} |- App f arg +Lam zzzz (zzzz) + diff --git a/ppx_elpi/tests/test_two_layers_context.expected.ml b/ppx_elpi/tests/test_two_layers_context.expected.ml new file mode 100644 index 000000000..da94e4b65 --- /dev/null +++ b/ppx_elpi/tests/test_two_layers_context.expected.ml @@ -0,0 +1,1209 @@ +let elpi_stuff = ref [] +module String = + struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show x = x + end +let pp_tctx _ _ = () +type tctx = + | TDecl of ((string)[@elpi.key ]) * bool [@@deriving + elpi + { + index = (module String); + append = elpi_stuff + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_tctx = "tctx" + let elpi_constant_type_tctxc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_tctx + let elpi_constant_constructor_tctx_TDecl = "tdecl" + let elpi_constant_constructor_tctx_TDeclc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tctx_TDecl + module Elpi_tctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_tctx_state = + Elpi.API.State.declare ~name:"tctx" + ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") + ~init:(fun () -> + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.ContextualConversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))) + let elpi_tctx_to_key ~depth:_ = function | TDecl (elpi__1, _) -> elpi__1 + let elpi_is_tctx ~depth:elpi__depth elpi__x = + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const _ -> None + | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> + if false || (elpi__hd == elpi_constant_constructor_tctx_TDeclc) + then + (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with + | Elpi.API.RawData.Const x -> Some x + | _ -> + Elpi.API.Utils.type_error + "context entry applied to a non nominal") + else None + | _ -> None + let elpi_push_tctx ~depth:elpi__depth elpi__state elpi__name + elpi__ctx_item = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_tctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item + elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_tctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__name = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_tctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_tctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let rec elpi_embed_tctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__10, TDecl (elpi__8, elpi__9)) -> + let (elpi__state, elpi__14, elpi__11) = + Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__10 in + let (elpi__state, elpi__15, elpi__12) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__8 in + let (elpi__state, elpi__16, elpi__13) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__9 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_tctx_TDeclc + [elpi__14; elpi__15; elpi__16]), + (List.concat [elpi__11; elpi__12; elpi__13])) + let rec elpi_readback_tctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_tctx_TDeclc -> + let (elpi__state, elpi__7, elpi__6) = + Elpi.API.PPX.readback_nominal ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__2::elpi__3::[] -> + let (elpi__state, elpi__2, elpi__4) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__2 in + let (elpi__state, elpi__3, elpi__5) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__3 in + (elpi__state, (elpi__7, (TDecl (elpi__2, elpi__3))), + (List.concat [elpi__6; elpi__4; elpi__5])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_tctx_TDeclc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "tctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let tctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "tctx" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.ContextualConversion.TyName "prop") + ~name:"tdecl" ~doc:"TDecl" + ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); + embed = elpi_embed_tctx; + readback = elpi_readback_tctx + } + let in_tctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state = + let module CMap = Elpi.API.RawData.Constants.Map in + let elpi__filtered_hyps = + List.fold_left + (fun elpi__m -> + fun + ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as + elpi__hyp) + -> + match elpi_is_tctx ~depth:elpi__i elpi__hsrc with + | None -> elpi__m + | Some elpi__idx -> + (if CMap.mem elpi__idx elpi__m + then + Elpi.API.Utils.type_error + "more than one context entry for the same nominal"; + CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty + (Elpi.API.RawData.of_hyps elpi__hyps) in + let rec elpi__aux elpi__state elpi__gls elpi__i = + if elpi__i = elpi__depth + then (elpi__state, (List.concat (List.rev elpi__gls))) + else + if not (CMap.mem elpi__i elpi__filtered_hyps) + then elpi__aux elpi__state elpi__gls (elpi__i + 1) + else + (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in + let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in + let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = + tctx.Elpi.API.ContextualConversion.readback + ~depth:elpi__hyp_depth elpi__hyps elpi__constraints + elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + assert (elpi__nominal = elpi__i); + (let elpi__s = elpi_tctx_to_key ~depth:elpi__hyp_depth elpi__t in + let elpi__state = + elpi_push_tctx ~depth:elpi__i elpi__state elpi__s + { + Elpi.API.ContextualConversion.entry = elpi__t; + depth = elpi__hyp_depth + } in + elpi__aux elpi__state (elpi__gls_t :: elpi__gls) + (elpi__i + 1))) in + let elpi__state = + Elpi.API.State.set elpi_tctx_state elpi__state + (Elpi_tctx_Map.empty, CMap.empty) in + let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) + let in_tctx = in_tctx_alone + let elpi_tctx = Elpi.API.BuiltIn.MLDataC tctx + let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_tctx] @ [])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_tye _ _ = () +type tye = + | TVar of string [@elpi.var ] + | TConst of string + | TArrow of tye * tye [@@deriving + elpi + { + context = (x : tye -> tctx); + append = elpi_stuff + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_tye = "tye" + let elpi_constant_type_tyec = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_tye + let elpi_constant_constructor_tye_TVar = "tvar" + let elpi_constant_constructor_tye_TVarc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tye_TVar + let elpi_constant_constructor_tye_TConst = "tconst" + let elpi_constant_constructor_tye_TConstc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tye_TConst + let elpi_constant_constructor_tye_TArrow = "tarrow" + let elpi_constant_constructor_tye_TArrowc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tye_TArrow + let rec elpi_embed_tye : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (tye, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | TVar elpi__25 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__25 in + (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | TConst elpi__28 -> + let (elpi__state, elpi__30, elpi__29) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__28 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_tye_TConstc [elpi__30]), + (List.concat [elpi__29])) + | TArrow (elpi__31, elpi__32) -> + let (elpi__state, elpi__35, elpi__33) = + elpi_embed_tye ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__31 in + let (elpi__state, elpi__36, elpi__34) = + elpi_embed_tye ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__32 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_tye_TArrowc + [elpi__35; elpi__36]), + (List.concat [elpi__33; elpi__34])) + let rec elpi_readback_tye : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (tye, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.ContextualConversion.pp_ctx_entry + pp_tctx)) elpi__dbl2ctx); + (let { + Elpi.API.ContextualConversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (TVar + (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_tye_TConstc -> + let (elpi__state, elpi__20, elpi__19) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (TConst elpi__20), + (List.concat [elpi__19])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_tye_TConstc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_tye_TArrowc -> + let (elpi__state, elpi__24, elpi__23) = + elpi_readback_tye ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__21::[] -> + let (elpi__state, elpi__21, elpi__22) = + elpi_readback_tye ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__21 in + (elpi__state, (TArrow (elpi__24, elpi__21)), + (List.concat [elpi__23; elpi__22])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_tye_TArrowc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "tye" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let tye : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (tye, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "tye" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tye"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tconst" + ~doc:"TConst" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tarrow" + ~doc:"TArrow" + ~args:[Elpi.API.ContextualConversion.TyName + elpi_constant_type_tye; + Elpi.API.ContextualConversion.TyName + elpi_constant_type_tye]); + pp = pp_tye; + embed = elpi_embed_tye; + readback = elpi_readback_tye + } + let elpi_tye = Elpi.API.BuiltIn.MLDataC tye + let () = + elpi_stuff := + ((!elpi_stuff) @ + ([elpi_tye] @ + [Elpi.API.BuiltIn.LPCode + (String.concat "\n" + ["pred map.tye i:tye, o:tye."; + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "tye" "" + "tvar" "A0" "tvar" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "tye" "" + "tconst" "A0" "tconst" "B0" + (String.concat ", " + ["(" ^ + ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); + Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "tye" "" + "tarrow" "A0 A1" "tarrow" "B0 B1" + (String.concat ", " + ["(" ^ + (("map." ^ elpi_constant_type_tye) ^ + (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); + "(" ^ + (("map." ^ elpi_constant_type_tye) ^ + (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); + "\n"])])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_ty _ _ = () +type ty = + | Mono of tye + | Forall of string * bool * + ((ty)[@elpi.binder tye (fun s -> fun b -> TDecl (s, b))]) [@@deriving + elpi + { + context = + (x : + ((tye -> + tctx) * + (ty -> + tctx))) + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_ty = "ty" + let elpi_constant_type_tyc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ty + let elpi_constant_constructor_ty_Mono = "mono" + let elpi_constant_constructor_ty_Monoc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_Mono + let elpi_constant_constructor_ty_Forall = "forall" + let elpi_constant_constructor_ty_Forallc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_Forall + let rec elpi_embed_ty : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | Mono elpi__45 -> + let (elpi__state, elpi__47, elpi__46) = + tye.Elpi.API.ContextualConversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__45 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ty_Monoc [elpi__47]), + (List.concat [elpi__46])) + | Forall (elpi__48, elpi__49, elpi__50) -> + let (elpi__state, elpi__54, elpi__51) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__48 in + let (elpi__state, elpi__55, elpi__52) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__49 in + let elpi__ctx_entry = + (fun s -> fun b -> TDecl (s, b)) elpi__48 elpi__49 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__57, elpi__53) = + elpi_embed_ty ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__50 in + let elpi__56 = Elpi.API.RawData.mkLam elpi__57 in + let elpi__state = + elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ty_Forallc + [elpi__54; elpi__55; elpi__56]), + (List.concat [elpi__51; elpi__52; elpi__53])) + let rec elpi_readback_ty : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_Monoc -> + let (elpi__state, elpi__38, elpi__37) = + tye.Elpi.API.ContextualConversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (Mono elpi__38), + (List.concat [elpi__37])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_Monoc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_Forallc -> + let (elpi__state, elpi__44, elpi__43) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__39::elpi__40::[] -> + let (elpi__state, elpi__39, elpi__41) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__39 in + let elpi__ctx_entry = + (fun s -> fun b -> TDecl (s, b)) elpi__44 elpi__39 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth + elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = + elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__40, elpi__42) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__40 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_ty ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, + (Forall (elpi__44, elpi__39, elpi__40)), + (List.concat [elpi__43; elpi__41; elpi__42])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_Forallc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ty" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let ty : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "ty" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ty"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"mono" + ~doc:"Mono" ~args:[tye.Elpi.API.ContextualConversion.ty]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"forall" + ~doc:"Forall" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyApp + ("->", (Elpi.API.ContextualConversion.TyName "tye"), + [Elpi.API.ContextualConversion.TyName + elpi_constant_type_ty])]); + pp = pp_ty; + embed = elpi_embed_ty; + readback = elpi_readback_ty + } + let elpi_ty = Elpi.API.BuiltIn.MLDataC ty + end[@@ocaml.doc "@inline"][@@merlin.hide ] +let pp_ctx _ _ = () +type ctx = + | Decl of ((string)[@elpi.key ]) * ty [@@deriving + elpi + { + index = (module String); + context = (x : tctx); + append = elpi_stuff + }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_ctx = "ctx" + let elpi_constant_type_ctxc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ctx + let elpi_constant_constructor_ctx_Decl = "decl" + let elpi_constant_constructor_ctx_Declc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ctx_Decl + module Elpi_ctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_ctx_state = + Elpi.API.State.declare ~name:"ctx" + ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") + ~init:(fun () -> + ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant + Elpi_ctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : ctx + Elpi.API.ContextualConversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))) + let elpi_ctx_to_key ~depth:_ = function | Decl (elpi__58, _) -> elpi__58 + let elpi_is_ctx ~depth:elpi__depth elpi__x = + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const _ -> None + | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> + if false || (elpi__hd == elpi_constant_constructor_ctx_Declc) + then + (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with + | Elpi.API.RawData.Const x -> Some x + | _ -> + Elpi.API.Utils.type_error + "context entry applied to a non nominal") + else None + | _ -> None + let elpi_push_ctx ~depth:elpi__depth elpi__state elpi__name + elpi__ctx_item = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_ctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item + elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let elpi_pop_ctx ~depth:elpi__depth elpi__state elpi__name = + let (elpi__ctx2dbl, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__i = elpi__depth in + let elpi__ctx2dbl = Elpi_ctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__dbl2ctx = + Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (elpi__ctx2dbl, elpi__dbl2ctx) in + elpi__state + let rec elpi_embed_ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__67, Decl (elpi__65, elpi__66)) -> + let (elpi__state, elpi__71, elpi__68) = + Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__67 in + let (elpi__state, elpi__72, elpi__69) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__65 in + let (elpi__state, elpi__73, elpi__70) = + ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__66 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ctx_Declc + [elpi__71; elpi__72; elpi__73]), + (List.concat [elpi__68; elpi__69; elpi__70])) + let rec elpi_readback_ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ctx_Declc -> + let (elpi__state, elpi__64, elpi__63) = + Elpi.API.PPX.readback_nominal ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__59::elpi__60::[] -> + let (elpi__state, elpi__59, elpi__61) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__59 in + let (elpi__state, elpi__60, elpi__62) = + ty.Elpi.API.ContextualConversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__60 in + (elpi__state, + (elpi__64, (Decl (elpi__59, elpi__60))), + (List.concat [elpi__63; elpi__61; elpi__62])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ctx_Declc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let ctx : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, + 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "ctx" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.ContextualConversion.TyName "prop") + ~name:"decl" ~doc:"Decl" + ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; + (Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + ty.Elpi.API.ContextualConversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); + embed = elpi_embed_ctx; + readback = elpi_readback_ctx + } + let in_ctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state = + let module CMap = Elpi.API.RawData.Constants.Map in + let elpi__filtered_hyps = + List.fold_left + (fun elpi__m -> + fun + ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as + elpi__hyp) + -> + match elpi_is_ctx ~depth:elpi__i elpi__hsrc with + | None -> elpi__m + | Some elpi__idx -> + (if CMap.mem elpi__idx elpi__m + then + Elpi.API.Utils.type_error + "more than one context entry for the same nominal"; + CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty + (Elpi.API.RawData.of_hyps elpi__hyps) in + let rec elpi__aux elpi__state elpi__gls elpi__i = + if elpi__i = elpi__depth + then (elpi__state, (List.concat (List.rev elpi__gls))) + else + if not (CMap.mem elpi__i elpi__filtered_hyps) + then elpi__aux elpi__state elpi__gls (elpi__i + 1) + else + (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in + let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in + let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = + ctx.Elpi.API.ContextualConversion.readback + ~depth:elpi__hyp_depth elpi__hyps elpi__constraints + elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + assert (elpi__nominal = elpi__i); + (let elpi__s = elpi_ctx_to_key ~depth:elpi__hyp_depth elpi__t in + let elpi__state = + elpi_push_ctx ~depth:elpi__i elpi__state elpi__s + { + Elpi.API.ContextualConversion.entry = elpi__t; + depth = elpi__hyp_depth + } in + elpi__aux elpi__state (elpi__gls_t :: elpi__gls) + (elpi__i + 1))) in + let elpi__state = + Elpi.API.State.set elpi_ctx_state elpi__state + (Elpi_ctx_Map.empty, CMap.empty) in + let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) + let in_ctx = + Elpi.API.ContextualConversion.(|+|) in_tctx_alone in_ctx_alone + let elpi_ctx = Elpi.API.BuiltIn.MLDataC ctx + let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_ctx] @ [])) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +type term = + | Var of string [@elpi.var ] + | App of term list [@elpi.code "appl"][@elpi.doc "bla bla"] + | Lam of string * ty * + ((term)[@elpi.binder term (fun s -> fun ty -> Decl (s, ty))]) + | Literal of int [@elpi.skip ] + | Cast of term * ty + [@elpi.embed + fun default -> + fun ~depth -> + fun hyps -> + fun constraints -> + fun state -> + fun a1 -> fun a2 -> default ~depth hyps constraints state a1 a2] + [@elpi.readback + fun default -> + fun ~depth -> + fun hyps -> + fun constraints -> + fun state -> fun l -> default ~depth hyps constraints state l] + [@elpi.code "type-cast" "term -> ty -> term"][@@deriving + elpi + { + context = + (x : ((ty -> tctx) * + (term -> ctx))) + }][@@elpi.pp + let rec aux fmt = + function + | Var s -> + Format.fprintf + fmt "%s" s + | App tl -> + Format.fprintf + fmt "App %a" + (Elpi.API.RawPp.list + aux " ") tl + | Lam (s, ty, t) -> + Format.fprintf + fmt + "Lam %s (%a)" + s aux t + | Literal i -> + Format.fprintf + fmt "%d" i + | Cast (t, _) -> + aux fmt t in + aux] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_term = "term" + let elpi_constant_type_termc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_term + let elpi_constant_constructor_term_Var = "var" + let elpi_constant_constructor_term_Varc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Var + let elpi_constant_constructor_term_App = "appl" + let elpi_constant_constructor_term_Appc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_App + let elpi_constant_constructor_term_Lam = "lam" + let elpi_constant_constructor_term_Lamc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Lam + let elpi_constant_constructor_term_Cast = "type-cast" + let elpi_constant_constructor_term_Castc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Cast + let rec elpi_embed_term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | Var elpi__88 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__88 in + (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | App elpi__91 -> + let (elpi__state, elpi__93, elpi__92) = + (Elpi.API.PPX.embed_list elpi_embed_term) + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__91 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Appc [elpi__93]), + (List.concat [elpi__92])) + | Lam (elpi__94, elpi__95, elpi__96) -> + let (elpi__state, elpi__100, elpi__97) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__94 in + let (elpi__state, elpi__101, elpi__98) = + ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__95 in + let elpi__ctx_entry = + (fun s -> fun ty -> Decl (s, ty)) elpi__94 elpi__95 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__103, elpi__99) = + elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__96 in + let elpi__102 = Elpi.API.RawData.mkLam elpi__103 in + let elpi__state = + elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Lamc + [elpi__100; elpi__101; elpi__102]), + (List.concat [elpi__97; elpi__98; elpi__99])) + | Literal _ -> + Elpi.API.Utils.error + ("constructor " ^ ("Literal" ^ " is not supported")) + | Cast (elpi__104, elpi__105) -> + ((fun default -> + fun ~depth -> + fun hyps -> + fun constraints -> + fun state -> + fun a1 -> + fun a2 -> + default ~depth hyps constraints state a1 a2)) + (fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__104 -> + fun elpi__105 -> + let (elpi__state, elpi__108, elpi__106) = + elpi_embed_term ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__104 in + let (elpi__state, elpi__109, elpi__107) = + ty.Elpi.API.ContextualConversion.embed + ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__105 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Castc + [elpi__108; elpi__109]), + (List.concat [elpi__106; elpi__107]))) + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__104 elpi__105 + let rec elpi_readback_term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.ContextualConversion.pp_ctx_entry + pp_ctx)) elpi__dbl2ctx); + (let { + Elpi.API.ContextualConversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (Var (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Appc -> + let (elpi__state, elpi__77, elpi__76) = + (Elpi.API.PPX.readback_list elpi_readback_term) + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | [] -> + (elpi__state, (App elpi__77), + (List.concat [elpi__76])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Appc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Lamc -> + let (elpi__state, elpi__83, elpi__82) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__78::elpi__79::[] -> + let (elpi__state, elpi__78, elpi__80) = + ty.Elpi.API.ContextualConversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__78 in + let elpi__ctx_entry = + (fun s -> fun ty -> Decl (s, ty)) elpi__83 + elpi__78 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.ContextualConversion.entry = + elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__79, elpi__81) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__79 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_term ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (Lam (elpi__83, elpi__78, elpi__79)), + (List.concat [elpi__82; elpi__80; elpi__81])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Lamc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Castc -> + ((fun default -> + fun ~depth -> + fun hyps -> + fun constraints -> + fun state -> + fun l -> + default ~depth hyps constraints state l)) + (fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | elpi__x::elpi__xs -> + let (elpi__state, elpi__87, elpi__86) = + elpi_readback_term ~depth:elpi__depth + elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | elpi__84::[] -> + let (elpi__state, elpi__84, elpi__85) + = + ty.Elpi.API.ContextualConversion.readback + ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state + elpi__84 in + (elpi__state, + (Cast (elpi__87, elpi__84)), + (List.concat [elpi__86; elpi__85])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " + ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Castc))) + | [] -> + Elpi.API.Utils.error + ~loc:{ + Elpi.API.Ast.Loc.source_name = + "test_two_layers_context.ml"; + source_start = 1777; + source_stop = 1777; + line = 49; + line_starts_at = 1766 + } + "standard branch readback takes 1 argument or more") + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state (elpi__x :: elpi__xs) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let term : + 'elpi__param__poly_hyps 'elpi__param__poly_csts . + (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) + Elpi.API.ContextualConversion.t + = + let kind = Elpi.API.ContextualConversion.TyName "term" in + { + Elpi.API.ContextualConversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; + (Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"appl" + ~doc:"bla bla" + ~args:[Elpi.API.ContextualConversion.TyApp + ("list", + (Elpi.API.ContextualConversion.TyName + elpi_constant_type_term), [])]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" + ~doc:"Lam" + ~args:[(Elpi.API.ContextualConversion.(!>) + Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; + ty.Elpi.API.ContextualConversion.ty; + Elpi.API.ContextualConversion.TyApp + ("->", + (Elpi.API.ContextualConversion.TyName "term"), + [Elpi.API.ContextualConversion.TyName + elpi_constant_type_term])]); + Format.fprintf fmt "@[type %s@[ %s. %% %s@]@]@\n" + "type-cast" "term -> ty -> term" "Cast"); + pp = + (let rec aux fmt = + function + | Var s -> Format.fprintf fmt "%s" s + | App tl -> + Format.fprintf fmt "App %a" (Elpi.API.RawPp.list aux " ") tl + | Lam (s, ty, t) -> Format.fprintf fmt "Lam %s (%a)" s aux t + | Literal i -> Format.fprintf fmt "%d" i + | Cast (t, _) -> aux fmt t in + aux); + embed = elpi_embed_term; + readback = elpi_readback_term + } + let elpi_term = Elpi.API.BuiltIn.MLDataC term + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +open BuiltInPredicate +open Notation +let term_to_string = + Pred + ("term->string", + (CIn + (term, "T", + (COut + ((ContextualConversion.(!>) BuiltInData.string), "S", + (Read (in_ctx, "what else")))))), + (fun (t : term) -> + fun (_ety : string oarg) -> + fun ~depth:_ -> + fun + ((ctx1, ctx2) : + (tctx ContextualConversion.ctx_entry RawData.Constants.Map.t + * ctx ContextualConversion.ctx_entry + RawData.Constants.Map.t)) + -> + fun (_cst : Data.constraints) -> + fun (_state : State.t) -> + !: + (Format.asprintf "@[%a@ %a@ |-@ %a@]@\n%!" + (RawData.Constants.Map.pp + (ContextualConversion.pp_ctx_entry pp_tctx)) ctx1 + (RawData.Constants.Map.pp + (ContextualConversion.pp_ctx_entry pp_ctx)) ctx2 + term.pp t))) +let builtin = + let open BuiltIn in + declare ~file_name:"test_ppx.elpi" + ((!elpi_stuff) @ + ([MLCode (term_to_string, DocAbove); + LPDoc "----------------- elpi ----------------"] @ + (let open Elpi.Builtin in core_builtins @ elpi_builtins))) +let program = + {| +main :- + pi x w y q t\ + tdecl t "alpha" tt => + decl y "arg" (forall "ss" tt s\ mono (tarrow (tconst "nat") s)) => + decl x "f" (mono (tarrow (tconst "nat") t)) => + print {term->string (appl [x, y, lam "zzzz" (mono t) z\ z])}. + +|} +let main () = + let (elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + let out = open_out (Sys.argv.(1)) in + let fmt = Format.formatter_of_out_channel out in + Setup.set_err_formatter fmt; + Setup.set_std_formatter fmt; + (let program = + Parse.program_from_stream ~elpi (Ast.Loc.initial "test") + (let open Stream in of_string program) in + let goal = Parse.goal (Ast.Loc.initial "test") "main." in + let program = Compile.program ~elpi ~flags:Compile.default_flags [program] in + let goal = Compile.query program goal in + let exe = Compile.optimize goal in + match Execute.once exe with + | Execute.Success _ -> + (Format.pp_print_flush fmt (); close_out out; exit 0) + | _ -> exit 1) +;;main () diff --git a/ppx_elpi/tests/test_two_layers_context.ml b/ppx_elpi/tests/test_two_layers_context.ml new file mode 100644 index 000000000..5b5ca8ef6 --- /dev/null +++ b/ppx_elpi/tests/test_two_layers_context.ml @@ -0,0 +1,103 @@ +let elpi_stuff = ref [] + +module String = struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show x = x +end + +let pp_tctx _ _ = () +type tctx = TDecl of (string[@elpi.key]) * bool +[@@deriving elpi { index = (module String) ; append = elpi_stuff } ] + +let pp_tye _ _ = () +type tye = + | TVar of string [@elpi.var] + | TConst of string + | TArrow of tye * tye +[@@deriving elpi { context = (x : (tye -> tctx) ) ; append = elpi_stuff } ] + +let pp_ty _ _ = () +type ty = + | Mono of tye + | Forall of string * bool * (ty[@elpi.binder tye (fun s b -> TDecl(s,b))]) +[@@deriving elpi { context = (x : (tye -> tctx) * (ty -> tctx)) }] + +let pp_ctx _ _ = () +type ctx = Decl of (string[@elpi.key]) * ty +[@@deriving elpi { index = (module String); context = (x : tctx) ; append = elpi_stuff } ] + +type term = + | Var of string [@elpi.var] + | App of term list [@elpi.code "appl"] [@elpi.doc "bla bla"] + | Lam of string * ty * (term[@elpi.binder term (fun s ty -> Decl(s,ty))]) + | Literal of int [@elpi.skip] + | Cast of term * ty + (* Example: override the embed and readback code for this constructor *) + [@elpi.embed fun default ~depth hyps constraints state a1 a2 -> + default ~depth hyps constraints state a1 a2 ] + [@elpi.readback fun default ~depth hyps constraints state l -> + default ~depth hyps constraints state l ] + [@elpi.code "type-cast" "term -> ty -> term"] +[@@deriving elpi { context = (x : (ty -> tctx) * (term -> ctx)) } ] +[@@elpi.pp let rec aux fmt = function + | Var s -> Format.fprintf fmt "%s" s + | App tl -> Format.fprintf fmt "App %a" (Elpi.API.RawPp.list aux " ") tl + | Lam(s,ty,t) -> Format.fprintf fmt "Lam %s (%a)" s aux t + | Literal i -> Format.fprintf fmt "%d" i + | Cast(t,_) -> aux fmt t + in aux ] + +open Elpi.API +open BuiltInPredicate +open Notation + +let term_to_string = Pred("term->string", + CIn(term,"T", + COut(ContextualConversion.(!>) BuiltInData.string,"S", + Read(in_ctx, "what else"))), + fun (t : term) (_ety : string oarg) + ~depth:_ ((ctx1,ctx2) : tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx ContextualConversion.ctx_entry RawData.Constants.Map.t) + (_cst : Data.constraints) (_state : State.t) -> + + !: (Format.asprintf "@[%a@ %a@ |-@ %a@]@\n%!" + (RawData.Constants.Map.pp (ContextualConversion.pp_ctx_entry pp_tctx)) ctx1 + (RawData.Constants.Map.pp (ContextualConversion.pp_ctx_entry pp_ctx)) ctx2 + term.pp t) + +) + +let builtin = let open BuiltIn in + declare ~file_name:"test_ppx.elpi" (!elpi_stuff @ [ + MLCode(term_to_string,DocAbove); + LPDoc "----------------- elpi ----------------" + ] @ Elpi.Builtin.(core_builtins @ elpi_builtins)) + +let program = {| +main :- + pi x w y q t\ + tdecl t "alpha" tt => + decl y "arg" (forall "ss" tt s\ mono (tarrow (tconst "nat") s)) => + decl x "f" (mono (tarrow (tconst "nat") t)) => + print {term->string (appl [x, y, lam "zzzz" (mono t) z\ z])}. + +|} + +let main () = + let elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + let out = open_out Sys.argv.(1) in + let fmt = Format.formatter_of_out_channel out in + Setup.set_err_formatter fmt; + Setup.set_std_formatter fmt; + let program = Parse.program_from_stream ~elpi (Ast.Loc.initial "test") + Stream.(of_string program) in + let goal = Parse.goal (Ast.Loc.initial "test") "main." in + let program = Compile.program ~elpi ~flags:Compile.default_flags [program] in + let goal = Compile.query program goal in + let exe = Compile.optimize goal in + match Execute.once exe with + | Execute.Success _ -> Format.pp_print_flush fmt (); close_out out; exit 0 + | _ -> exit 1 + ;; + +main () \ No newline at end of file diff --git a/src/builtin.ml b/src/builtin.ml index 2a55ee152..c67883100 100644 --- a/src/builtin.ml +++ b/src/builtin.ml @@ -1386,3 +1386,29 @@ let default_checker () = let elpi, _ = API.Setup.init ~builtins:[std_builtins] ~basedir:(Sys.getcwd ()) [] in let ast = API.Parse.program_from_stream ~elpi (API.Ast.Loc.initial "(checker)") (Stream.of_string Builtin_checker.code) in API.Compile.program ~flags:API.Compile.default_flags ~elpi [ast] + +module PPX = struct + + let readback_pair = readback_pair + let readback_option = readback_option + let readback_bool ~depth _ c s x = bool.API.Conversion.readback ~depth (new Conversion.ctx []) c s x + let readback_char ~depth _ c s x = char.API.Conversion.readback ~depth (new Conversion.ctx []) c s x + + let readback_triple = readback_triple + let readback_quadruple = readback_quadruple + let readback_quintuple = readback_quintuple + + let embed_pair = embed_pair + let embed_option = embed_option + let embed_bool ~depth _ c s x = bool.API.Conversion.embed ~depth (new Conversion.ctx []) c s x + let embed_char ~depth _ c s x = char.API.Conversion.embed ~depth (new Conversion.ctx []) c s x + + let embed_triple = embed_triple + let embed_quadruple = embed_quadruple + let embed_quintuple = embed_quintuple + + let declarations = let open BuiltIn in let open BuiltInData in [ + LPCode Builtin_ppx.code + ] + +end diff --git a/src/builtin.mli b/src/builtin.mli index e357bef06..329eaf31c 100644 --- a/src/builtin.mli +++ b/src/builtin.mli @@ -54,3 +54,27 @@ val quintuple : ('a, 'h) API.Conversion.t -> ('b, 'h) API.Conversion.t -> ('c, ' (* This is the default checker [elpi-checker] *) val default_checker : unit -> API.Compile.program + +module PPX : sig + (** internal API for elpi.ppx *) + + val readback_pair : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('a * 'b, 'h) API.Conversion.readback + val readback_option : ('a, 'h) API.Conversion.readback -> ('a option, 'h) API.Conversion.readback + val readback_bool : (bool, 'h) API.Conversion.readback + val readback_char : (char, 'h) API.Conversion.readback + + val readback_triple : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('c, 'h) API.Conversion.readback -> ('a * 'b * 'c, 'h) API.Conversion.readback + val readback_quadruple : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('c, 'h) API.Conversion.readback -> ('d, 'h) API.Conversion.readback -> ('a * 'b * 'c * 'd, 'h) API.Conversion.readback + val readback_quintuple : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('c, 'h) API.Conversion.readback -> ('d, 'h) API.Conversion.readback -> ('e, 'h) API.Conversion.readback -> ('a * 'b * 'c * 'd * 'e, 'h) API.Conversion.readback + + val embed_pair : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('a * 'b, 'h) API.Conversion.embedding + val embed_option : ('a, 'h) API.Conversion.embedding -> ('a option, 'h) API.Conversion.embedding + val embed_bool : (bool, 'h) API.Conversion.embedding + val embed_char : (char, 'h) API.Conversion.embedding + + val embed_triple : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('c, 'h) API.Conversion.embedding -> ('a * 'b * 'c, 'h) API.Conversion.embedding + val embed_quadruple : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('c, 'h) API.Conversion.embedding -> ('d, 'h) API.Conversion.embedding -> ('a * 'b * 'c * 'd, 'h) API.Conversion.embedding + val embed_quintuple : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('c, 'h) API.Conversion.embedding -> ('d, 'h) API.Conversion.embedding -> ('e, 'h) API.Conversion.embedding -> ('a * 'b * 'c * 'd * 'e, 'h) API.Conversion.embedding + + val declarations : declaration list +end \ No newline at end of file diff --git a/src/builtin_ppx.elpi b/src/builtin_ppx.elpi new file mode 100644 index 000000000..7a41e1a2c --- /dev/null +++ b/src/builtin_ppx.elpi @@ -0,0 +1,23 @@ +namespace ppx { + +pred map.list i:(A -> B -> prop), i:list A, o:list B. +map.list _ [] []. +map.list F [X|XS] [Y|YS] :- F X Y, map.list F XS YS. + +pred map.option i:(A -> B -> prop), i:option A, o:option B. +map.option _ none none. +map.option F (some X) (some Y) :- F X Y. + +pred map.pair i:(A1 -> B1 -> prop), i:(A2 -> B2 -> prop), i:pair A1 A2, o:pair B1 B2. +map.pair F1 F2 (pr X1 X2) (pr Y1 Y2) :- F1 X1 Y1, F2 X2 Y2. + +pred map.triple i:(A1 -> B1 -> prop), i:(A2 -> B2 -> prop), i:(A3 -> B3 -> prop), i:triple A1 A2 A3, o:triple B1 B2 B3. +map.triple F1 F2 F3 (triple X1 X2 X3) (triple Y1 Y2 Y3) :- F1 X1 Y1, F2 X2 Y2, F3 X3 Y3. + +pred map.quadruple i:(A1 -> B1 -> prop), i:(A2 -> B2 -> prop), i:(A3 -> B3 -> prop), i:(A4 -> B4 -> prop), i:quadruple A1 A2 A3 A4, o:quadruple B1 B2 B3 B4. +map.quadruple F1 F2 F3 F4 (quadruple X1 X2 X3 X4) (quadruple Y1 Y2 Y3 Y4) :- F1 X1 Y1, F2 X2 Y2, F3 X3 Y3, F4 X4 Y4. + +pred map.quintuple i:(A1 -> B1 -> prop), i:(A2 -> B2 -> prop), i:(A3 -> B3 -> prop), i:(A4 -> B4 -> prop), i:(A5 -> B5 -> prop), i:quintuple A1 A2 A3 A4 A5, o:quintuple B1 B2 B3 B4 B5. +map.quintuple F1 F2 F3 F4 F5 (quintuple X1 X2 X3 X4 X5) (quintuple Y1 Y2 Y3 Y4 Y5) :- F1 X1 Y1, F2 X2 Y2, F3 X3 Y3, F4 X4 Y4, F5 X5 Y5. + +} \ No newline at end of file diff --git a/src/dune b/src/dune index 336b1facf..15751e2a3 100644 --- a/src/dune +++ b/src/dune @@ -31,8 +31,8 @@ (-> ppx_deriving_runtime_proxy.embed.ml) )) (flags -linkall) - (modules elpi util parser ast compiler data ptmap builtin builtin_checker builtin_stdlib builtin_map builtin_set API runtime_trace_on runtime_trace_off ppx_deriving_runtime_proxy) - (private_modules util parser ast compiler data ptmap builtin_stdlib builtin_map builtin_set runtime_trace_on runtime_trace_off ppx_deriving_runtime_proxy) + (modules elpi util parser ast compiler data ptmap builtin builtin_checker builtin_stdlib builtin_map builtin_set builtin_ppx API runtime_trace_on runtime_trace_off ppx_deriving_runtime_proxy) + (private_modules util parser ast compiler data ptmap builtin_stdlib builtin_map builtin_set builtin_ppx runtime_trace_on runtime_trace_off ppx_deriving_runtime_proxy) ) (dirs .ppcache) @@ -56,6 +56,11 @@ (cat builtin_set.elpi) (echo "|code};;") ))) +(rule (with-stdout-to builtin_ppx.ml (progn + (echo "let code = {code|#line 0 \"builtin_ppx.elpi\"\n") + (cat builtin_ppx.elpi) + (echo "|code};;") +))) (rule (with-stdout-to builtin_checker.ml (progn (echo "let code = {code|") (echo "#line 0 \"elpi-quoted_syntax.elpi\"\n") From 69b274e3007d407c450ca2a982fb35c72afea282 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 16:58:06 +0200 Subject: [PATCH 5/7] ppx --- .travis.yml | 2 +- CHANGES.md | 3 + Makefile | 2 + ppx_elpi/dune | 2 +- ppx_elpi/ppx_elpi.ml | 1164 ++++++++++------- ppx_elpi/tests/dune | 1 + ppx_elpi/tests/dune.inc | 23 + ppx_elpi/tests/test_alias_type.expected.elpi | 3 - ppx_elpi/tests/test_alias_type.expected.ml | 44 +- ppx_elpi/tests/test_alias_type.ml | 4 +- .../test_double_contextual.expected.elpi | 22 +- .../tests/test_double_contextual.expected.ml | 853 ++++++------ ppx_elpi/tests/test_double_contextual.ml | 70 +- ppx_elpi/tests/test_mutual_adt.expected.elpi | 12 - ppx_elpi/tests/test_mutual_adt.expected.ml | 101 +- ppx_elpi/tests/test_mutual_adt.ml | 2 +- .../test_mutual_contextual.expected.elpi | 0 .../tests/test_mutual_contextual.expected.ml | 684 ++++++++++ ppx_elpi/tests/test_mutual_contextual.ml | 712 ++++++++++ ppx_elpi/tests/test_opaque_type.expected.ml | 85 +- ppx_elpi/tests/test_opaque_type.ml | 10 +- ppx_elpi/tests/test_poly_adt.expected.elpi | 7 - ppx_elpi/tests/test_poly_adt.expected.ml | 96 +- ppx_elpi/tests/test_poly_adt.ml | 8 +- ppx_elpi/tests/test_poly_alias.expected.elpi | 3 - ppx_elpi/tests/test_poly_alias.expected.ml | 74 +- ppx_elpi/tests/test_poly_alias.ml | 6 +- ppx_elpi/tests/test_simple_adt.expected.elpi | 6 - ppx_elpi/tests/test_simple_adt.expected.ml | 51 +- ppx_elpi/tests/test_simple_adt.ml | 2 +- .../test_simple_adt_record.expected.elpi | 6 - .../tests/test_simple_adt_record.expected.ml | 61 +- ppx_elpi/tests/test_simple_adt_record.ml | 4 +- .../test_simple_contextual.expected.elpi | 11 +- .../tests/test_simple_contextual.expected.ml | 430 +++--- ppx_elpi/tests/test_simple_contextual.ml | 54 +- .../tests/test_simple_record.expected.elpi | 5 - ppx_elpi/tests/test_simple_record.expected.ml | 54 +- ppx_elpi/tests/test_simple_record.ml | 2 +- .../test_two_layers_context.expected.elpi | 6 +- .../tests/test_two_layers_context.expected.ml | 719 +++++----- ppx_elpi/tests/test_two_layers_context.ml | 47 +- 42 files changed, 3483 insertions(+), 1968 deletions(-) create mode 100644 ppx_elpi/tests/test_mutual_contextual.expected.elpi create mode 100644 ppx_elpi/tests/test_mutual_contextual.expected.ml create mode 100644 ppx_elpi/tests/test_mutual_contextual.ml diff --git a/.travis.yml b/.travis.yml index 82da8793c..8d3d2d764 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ env: - OCAML_MIN=4.04.1 - OCAML_MAX=4.09.0 - PREDEPS="ocamlfind" - - DEPS="camlp5 ocamlfind ppx_deriving ppxlib re dune cmdliner ANSITerminal" + - DEPS="camlp5 ocamlfind ppx_deriving ppxlib stdcompat re dune cmdliner ANSITerminal" - MINDEPS="camlp5 ocamlfind dune re" - JOBS=2 diff --git a/CHANGES.md b/CHANGES.md index 4f7de9fcd..8952749bd 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,8 @@ ## v1.11.0 UNRELEASED +- PPX: + - new, experimental, elpi.ppx to generate glue code from an ADT declaration + - Stdlib: - triple, quadruple and quintuple data types - char builtin diff --git a/Makefile b/Makefile index 03939de28..423b38254 100644 --- a/Makefile +++ b/Makefile @@ -30,6 +30,7 @@ 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 --cookie '\''elpi_trace=\"true\"'\'''" >> src/.merlin );\ + ( echo "FLG -ppx './pp.exe --as-ppx '" >> ppx_elpi/tests/.merlin );\ exit $$RC install: @@ -46,6 +47,7 @@ cleancache: tests: $(MAKE) build + dune runtest --diff-command 'diff -w -u' ulimit -s $(STACK); \ tests/test.exe \ --seed $$RANDOM \ diff --git a/ppx_elpi/dune b/ppx_elpi/dune index 034b6549f..98b55a9df 100644 --- a/ppx_elpi/dune +++ b/ppx_elpi/dune @@ -2,7 +2,7 @@ (name ppx_elpi) (public_name elpi.ppx) (synopsis "[@@elpi]") - (libraries re ppxlib) + (libraries re ppxlib elpi) (preprocess (pps ppxlib.metaquot)) (ppx_runtime_libraries elpi) (modules ppx_elpi) diff --git a/ppx_elpi/ppx_elpi.ml b/ppx_elpi/ppx_elpi.ml index 346bb36b9..8044e518e 100644 --- a/ppx_elpi/ppx_elpi.ml +++ b/ppx_elpi/ppx_elpi.ml @@ -3,112 +3,182 @@ open Ppxlib.Ast_pattern (** - Deriving directives: + This PPX deriver can synthesize glue code for Elpi. The following kind of data + types are supported: - [@@deriving elpi] Simple ADT. - [@@deriving elpi { index = (module M) }] Context ADT. - M is an OrderedType and Show, it is used to instantiate the - functor Elpi.Utils.Map.Make. - All constructors must have 1 argument with attribute [@elpi.key] - and that argument must be of type M.t - [@@deriving elpi { context = (() : ty) }] HOADT. - Its context is represented by items of the context ADT ty, if ty is a - type name. - If ty is of the form "(ty1 -> ctx1) * .. * (tyn -> ctxn)" then the - context is represented by items of (the union of) the context ADTs - ctx1 ... ctxn. ": ty" stands for ": (current_type -> ty)". - Constructors can have the [@elpi.var] attribute and - constructor arguments can have the [@elpi.binder] attribute - [@@deriving elpi { append = l }] - appends to list (l : Elpi.API.BuiltIn.declaration list ref) - all data types that were derived - - In all cases the type must come with a pretty printer named following the - ppx_deriving.show convention (named pp if the type is named t, pp_ty - otherwise). Using both [@@derving show, elpi] on each data type is - the simplest option. + - Opaque, eg [type t] (or types with a definition but that one does not + want to expose to elpi). See the [@@elpi.opaque e] attribute. Phantom + parameters are not supported for now. -*) -let pexp_ignore = Deriving.Args.of_func (fun _ _ (_e : expression) b -> b) + - Alias, eg [type 'a t = ('a * int) list ]. + + - Algebraic, eg [type t = K | S]. Such a type can have two roles: + - a datum: a syntax tree, potentially with binders + - the context for a datum: all data with binders must be equipped with + one or more data types describing the info attached to bound variables. + + Example of a HOAS data type + + type lctx = + | Entry of string[@elpi.key] * ty + [@@elpi.index (module String)] + [@@deriving elpi] + + type l = + | Lam of string * ty * (term[@elpi.binder ctx ..]) + | Var of string [@elpi.variable ctx] + [@@deriving elpi] + + Output: + + class type ctx_for_l = object + inherit Conversion.ctx + method lctx : lctx Conversion.ctx_field + end + val l : 'c. (l, #ctx_for_l as 'c) Conversion.t + val in_ctx_for_l : ctx_for_l Conversion.ctx_readback + + Usage: predicates using HOAS arguments must specify a context large enough + for all arguments. + + Pred("term->string", + In(l, "T", + InOut(string, "S", + Read("what else"))), + in_ctx_for_l, + fun (x : l) _ ~depth:_ (c : ctx_for_l) (_ : Data.constraints) (_ : State.t) -> + ... x ... c#lctx ... + + Here in_ctx_for_l is a context rich enough to support the readback of data of + type l and string. + + Deriving directives: + [@@deriving elpi] + Derive a Elpi.API.Conversion.t for the data types in the + mutually recursive block. The name of the conversion in the one of the + type. See the Conventions section of this doc for mode info on the + naming of generated code. + [@@deriving elpi { context = [ty1; ...; tyn]}] + Specify the types describing the context under which the data type lives + and the order in which they should be read back. Default is the list + of types mentioned in [@elpi.binder] and [@elpi.var], in no specified + order. + [@@deriving elpi { declaration = l }] + Also append to list (l : Elpi.API.BuiltIn.declaration list ref) + all MLCData delarations that were derived. + [@@deriving elpi { mapper = l }] + Also append to list (l : Elpi.API.BuiltIn.declaration list ref) + all LPCode declarations of mappers for the data types, eg a + pred map.typename i:typename, o:typename + (with parameters if the type is a container). The mapper is identity + one, it is up to the user to place his code before this one and override + the cases he wants in order to implement a non trivial map. + + The type must come with a pretty printer named following the usual + convention (named pp if the type is named t, pp_ty otherwise). + Using both [@@derving show, elpi] on each data type is the simplest option + (from the ppx_show package, not the ppx_deriving one). + See also [@@elpi.pp]. -let arguments = Deriving.Args.(empty - +> arg "index" (pexp_pack __) - +> arg "context" (pexp_constraint pexp_ignore __) - +> arg "append" __ -) -(** Type attributes: - [@@elpi.code] - see the constructor attribute with the same name - [@@elpi.doc] - see the constructor attribute with the same name - [@@elpi.default_readback] - the default case can be used to read back flexible terms. The default is - a runtime type error - [@@elpi.pp] - code for pretty printing the data. Type is the one ppx_deriving.show - would produce -*) -let att_elpi_tcode = Attribute.(declare "elpi.code" Context.type_declaration (single_expr_payload __) (fun x -> x)) -let att_elpi_tdoc = Attribute.(declare "elpi.doc" Context.type_declaration (single_expr_payload (estring __)) (fun x -> x)) -let att_elpi_treadback = Attribute.(declare "elpi.default_readback" Context.type_declaration (single_expr_payload __) (fun x -> x)) -let att_elpi_pp = Attribute.(declare "elpi.pp" Context.type_declaration (single_expr_payload __) (fun x -> x)) -(** + [@@elpi.type_readback f] + [f] mandatory: a function of type Elpi.API.Conversion.readback. + Take over the readback of the entire type (useful in a block of mutually + recursive types). + + [@@elpi.type_embed f] + [f] mandatory: a function of type Elpi.API.Conversion.embedding. + Take over the embed of the entire type (useful in a block of mutually + recursive types). + + [@@elpi.pp f] + [f] mandatory: code for pretty printing the data. Its type is the one + ppx_deriving.show would produce. + + [@@elpi.type_code] + See the constructor attribute with name [code]. + + [@@elpi.type_doc] + See the constructor attribute with name [doc]. + + [@@elpi.default_constructor_readback f] + [f] mandatory: a function of type Elpi.API.Conversion.readback + called when the term is not any of the constructors. The default is a + runtime type error. This option can be used to read back flexible terms + (in addition to regular constructors). + + [@@elpi.index (module M)] + [M] mandatory: is an OrderedType and Show, it is used to instantiate the + functor Elpi.Utils.Map.Make. When used in a type, each + constructors must have exactly one argument with attribute [@elpi.key] + and that argument must be of type M.t. + + [@@elpi.opaque e] + [e] mandatory: is a Elpi.API.OpaqueData.declaration, it is necessary for + opaque data types. + Constructor attributes: - [@elpi.var] An Elpi bound variable. - Optional argument is a function from the constructor arguments to the - type being the [@elpi.key] for the context. + [@elpi.var ctx to_key] An Elpi bound variable. + [ctx] mandatory: is the name if the context in which the variable + is bound. + [to_key] optional: is a function from the constructor arguments to the + value being the [@elpi.key] for the context [ctx]. + [@elpi.skip] Not exposed to Elpi. - [@elpi.embed] Custom embedding code. - Argument of type Elpi.API.ContextualConversion.embedding - [@elpi.readback] Custom readback code. - Argument of type Elpi.API.ContextualConversion.embedding - [@elpi.code] Custom Elpi declaration. - First argument is a string and stands for the name of the type - constructor. The default is the name of the OCaml constructor in lowercase - where _ is replaced by - . Eg Foo_BAR becomes foo-bar. - Second argument is optional and is a string used as the Elpi type - for the constructor. Default is derived from the types of the fields. - [@elpi.doc] Custom documentation. - Argument is a string. Default doc is the name of the OCaml constructor -*) -let att_elpi_var = Attribute.(declare "elpi.var" Context.constructor_declaration (alt_option (single_expr_payload __) (pstr nil)) (fun x -> x)) -let att_elpi_skip = Attribute.(declare "elpi.skip" Context.constructor_declaration (pstr nil) ()) -let att_elpi_embed = Attribute.(declare "elpi.embed" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) -let att_elpi_readback = Attribute.(declare "elpi.readback" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) -let att_elpi_code = Attribute.(declare "elpi.code" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) -let att_elpi_doc = Attribute.(declare "elpi.doc" Context.constructor_declaration (single_expr_payload (estring __)) (fun x -> x)) -(** + + [@elpi.embed f] Custom embedding code. + [f] optional: function of type + Elpi.API.Conversion.(embedding -> embedding) + where the input function is the one this ppx would generate. If you + want to override it only in some cases, just call this argument in the + other ones. + + [@elpi.readback f] Custom readback code. + [f] optional: function of type + Elpi.API.Conversion.(readback -> readback) + see [@elpi.emebed]. + + [@elpi.code name code] Custom Elpi declaration. + [name] mandatory: a string that stands for the name of the type + constructor. The default is the name of the OCaml constructor in lowercase + where _ is replaced by - . Eg Foo_BAR becomes foo-bar. + [code] optional: is a string used as the Elpi type declaration for the + constructor. Default is derived from the types of the fields. Example + "type lam (term -> term) -> term. % Lam" + + [@elpi.doc s] Custom documentation. + [s] mandatory: a string. Default doc is the name of the OCaml constructor, + see the example above. Constructor field attribute: [@elpi.key] Field used as a key in the Map to values of this type. - [@elpi.binder] Field is below one binder. - First argument is optional and is a string (or an ident) and is the type - of the bound variable. Default value is the type to which [@@elpi : ty] - is applied. - Second argument is a function taking all other fields and returning - a ctx entry (a value in the type ty of [@@elpi : ty]) -*) -let att_elpi_key = Attribute.(declare "elpi.key" Context.core_type (pstr nil) ()) -let att_elpi_binder = Attribute.(declare "elpi.binder" Context.core_type (single_expr_payload __) (fun x -> x)) -(** + + [@elpi.binder ty ctx mk_ctx_entry] Field is below one binder. + [ty] optional: name (string) of the elpi abstraction type, + eg the "XXX" in (XXX -> term). Default is the type name. + [ctx] mandatory: name of the context in which the variable is bound + [mk_ctx_entry] mandatory: function taking all other fields and returning + a ctx entry (a value in the type [ctx]). + Extensions: [%elpi : ty] the conversion of type ty + This does not synthesize the conversion code but rather compose the + existing ones. Conventions: - is a value of type Elpi.API.ContextualConversion.t for type ty. + is a value of type Elpi.API.Conversion.t for type ty. - in_ is a value of type Elpi.API.ContextualConversion.ctx_readback - for type . It exists only for context ADTs. + in_ is a value of type Elpi.API.Conversion.ctx_readback + for type . Elpi__Map is a module of signature Elpi.API.Utils.Map.S built using - Elpi.API.Utils.Map.Make(M) where type ctx is a context ADT annotated as - [@@elpi (module M)]. It exists only for context ADTs. + Elpi.API.Utils.Map.Make(M) where type is annotated with + [@@elpi.index (module M)]. TODO: elpi_push_xxx elpi_pop_xxx elpi_xxx_state elpi_xxx_to_key elpi_xxx @@ -118,13 +188,42 @@ let att_elpi_binder = Attribute.(declare "elpi.binder" Context.core_type (single any variable named elpi_something or something. *) + +let arguments = Deriving.Args.(empty + +> arg "declaration" __ + +> arg "mapper" __ + +> arg "context" __ +) + +let att_elpi_tcode = Attribute.(declare "elpi.type_code" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_tdoc = Attribute.(declare "elpi.type_doc" Context.type_declaration (single_expr_payload (estring __)) (fun x -> x)) +let att_elpi_def_k_readback = Attribute.(declare "elpi.default_constructor_readback" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_tpp = Attribute.(declare "elpi.pp" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_treadback = Attribute.(declare "elpi.type_readback" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_tembed = Attribute.(declare "elpi.type_embed" Context.type_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_tindex = Attribute.(declare "elpi.index" Context.type_declaration (single_expr_payload (pexp_pack __)) (fun x -> x)) +let att_elpi_tcdata = Attribute.(declare "elpi.opaque" Context.type_declaration (single_expr_payload __) (fun x -> x)) + +let att_elpi_var = Attribute.(declare "elpi.var" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_skip = Attribute.(declare "elpi.skip" Context.constructor_declaration (pstr nil) ()) +let att_elpi_embed = Attribute.(declare "elpi.embed" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_readback = Attribute.(declare "elpi.readback" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_code = Attribute.(declare "elpi.code" Context.constructor_declaration (single_expr_payload __) (fun x -> x)) +let att_elpi_doc = Attribute.(declare "elpi.doc" Context.constructor_declaration (single_expr_payload (estring __)) (fun x -> x)) + +let att_elpi_key = Attribute.(declare "elpi.key" Context.core_type (pstr nil) ()) +let att_elpi_binder = Attribute.(declare "elpi.binder" Context.core_type (single_expr_payload __) (fun x -> x)) + let elpi_name_mangle txt = String.map (function '_' -> '-' | x -> x) @@ String.lowercase_ascii txt let elpi_map_name x = "Elpi_"^x^"_Map" let elpi_state_name x = "elpi_"^x^"_state" -let elpi_in_name_alone x = "in_" ^ x ^ "_alone" -let elpi_in_name x = "in_" ^ x +let elpi_ctx_class_module_name x = "Ctx_for_" ^ x +let elpi_ctx_class_name x = elpi_ctx_class_module_name x ^ ".t" +let elpi_ctx_object_name x = "ctx_for_" ^ x +let elpi_readback_ctx_name x = "context_made_of_" ^ x +let elpi_in_ctx_for_name x = "in_" ^ elpi_ctx_object_name x let elpi_to_key x = "elpi_" ^ x ^ "_to_key" let elpi_is_ctx_entry_name x = "elpi_is_" ^ x let elpi_embed_name x = "elpi_embed_" ^ x @@ -135,6 +234,7 @@ let elpi_kname t k = "elpi_constant_constructor_" ^ t ^ "_" ^ k ^ "c" let elpi_tname t = "elpi_constant_type_" ^ t ^ "c" let elpi_kname_str t k = "elpi_constant_constructor_" ^ t ^ "_" ^ k let elpi_tname_str t = "elpi_constant_type_" ^ t +let elpi_cdata_name x = "elpi_opaque_data_decl_" ^ x let param_prefix = "elpi__param__" let fresh = let x = ref 0 in @@ -142,10 +242,11 @@ let fresh = let elpi_Map ~loc x f = Ast_builder.Default.evar ~loc ("Elpi_"^x^"_Map." ^ f) -let is_some = function Some _ -> true | _ -> false +let option_is_some = function Some _ -> true | _ -> false let option_get = function Some x -> x | _ -> assert false let option_map f = function Some x -> Some (f x) | _ -> None let option_default d = function Some x -> x | _ -> d +let option_to_list = function Some x -> [x] | None -> [] let rec filter_map f = function | [] -> [] | x :: xs -> @@ -167,82 +268,68 @@ let elpi_loc_of_position (module B : Ast_builder.S) pos = let open B in line_starts_at = [%e eint @@ pos.pos_bol ]; }] -(* -let get_attr_expr s l = - match find_attr_expr s l with - | None -> error ("attribute " ^ s ^ " with no payload") - | Some e -> e -*) - - - let pexp_disable_warnings (module B : Ast_builder.S) x = [%expr [%e x ][@warning "-26-27-32-39-60"]] -let abstract_expr_over_params (module B : Ast_builder.S) vl f e = let open B in - let rec aux = function - | [] -> e - | v :: vs -> [%expr fun [%p pvar (f v) ] -> [%e aux vs]] - in - aux vl - let rec on_last f = function | [] -> assert false | [x] -> [f x] | y :: ys -> y :: on_last f ys -type directive = +type codegen_directive = | Standard - | Custom of expression * position - | Name of expression + | Custom of { ml : expression; pos : position } + | Name of { get_key : expression; ctx_name : string } let is_name = function Name _ -> true | _ -> false type arg_type = | FO of { - argFO_key : bool; - argFO_readback : expression; - argFO_embed : expression; - argFO_ty_ast : expression; - argFO_ty : core_type; + key : bool; (* has the [@elpi.key] attribute *) + readback : expression; + embed : expression; + ty_ast : expression; + ty : core_type; } - | HO of { - argHO_arrow_src : string; - argHO_build_ctx : expression; - argHO_readback : expression; - argHO_embed : expression; (* if context = SOMe map, then store here which component of the state one has to pick *) - argHO_ty_ast : expression; - argHO_ty : core_type; + | HO of { (* [@elpi.binder ctx build_ctx] *) + ctx : string; + build_ctx : expression; + arrow_src_elpi : string; (* name of ctx in elpi *) + readback : expression; + embed : expression; + ty_ast : expression; (* to generate the elpi type of the constructor *) + ty : core_type; } -let is_key = function FO { argFO_key = k; _ } -> k | _ -> false +let is_key = function FO { key = k; _ } -> k | _ -> false let is_HO = function HO _ -> true | _ -> false let ctx_index_ty (module B : Ast_builder.S) = let open B in FO { - argFO_readback = [%expr Elpi.API.PPX.readback_nominal ]; - argFO_embed = [%expr Elpi.API.PPX.embed_nominal ]; - argFO_ty_ast = [%expr Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty ]; - argFO_ty = [%type: int]; - argFO_key = false; + readback = [%expr Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback ]; + embed = [%expr Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed ]; + ty_ast = [%expr Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty ]; + ty = [%type: Elpi.API.Data.constant ]; + key = false; } type elpi_constructor = | Skip of { constructor_name : string; has_args : bool } | Expose of expose and expose = { - declaration : structure_item list; - constant : expression; - constant_name : string; - constructor : expression list -> expression; - pattern : pattern list -> pattern; - types : arg_type list; - embed : directive; - readback : directive; - elpi_code : expression option; (* string *) - elpi_doc : string; - } + declaration : structure_item list; (* constants for constructor *) + constant : expression; + constant_name : string; + constructor : expression list -> expression; + pattern : pattern list -> pattern; + arg_types : arg_type list; + embed : codegen_directive; + readback : codegen_directive; + elpi_code : expression option; (* string *) + elpi_doc : string; + ctx_names : string list; +} type elpi_type_decl = - | Opaque + | Opaque of expression | Alias of core_type | Algebraic of elpi_constructor list * expression option (* default readback *) @@ -254,21 +341,49 @@ type elpi_type = { params : string list; type_decl : elpi_type_decl; pp : expression option; + index : module_expr option; } -type task_kind = ADT | CTX of module_expr * string list | HOAS of (string * string) list -type task = elpi_type * task_kind +module SSet = struct (* We need to preserve the order *) + module SSet = Elpi.API.Utils.Set.Make(struct + include String + let pp fmt x = Format.pp_print_string fmt x + let show x = x + end) + + type t = string list + let mem = List.mem + let is_empty x = x = [] + let elements l = l + let of_list l = l + let subset l1 l2 = SSet.subset + (List.fold_right SSet.add l1 SSet.empty) + (List.fold_right SSet.add l2 SSet.empty) + let empty = [] + let add x l = if List.mem x l then l else x :: l + let pp fmt l = Elpi.API.RawPp.list Format.pp_print_string " " fmt l + let diff l1 l2 = SSet.diff + (List.fold_right SSet.add l1 SSet.empty) + (List.fold_right SSet.add l2 SSet.empty) |> SSet.elements +end + +type elpi_mutual_type = { + types : elpi_type list; + names : string list; + ctx_names : SSet.t; + context : (string * module_expr * elpi_type) option; +} type type_extras = { ty_constants : structure_item list; ty_embed : value_binding; ty_readback : value_binding; - ty_conversion : value_binding; + ty_ctx_class_type : structure_item; + ty_conversion : structure_item; ty_conversion_name : string; - ty_context_helpers : structure_item list; - ty_context_readback : structure_item list; ty_elpi_declaration : elpi_declaration; ty_opaque : bool; + ty_in_ctx : structure_item list; (* for contextual ADTs *) ty_library : expression option; (* should be Elpi AST *) } and elpi_declaration = { @@ -276,6 +391,19 @@ and elpi_declaration = { decl_name : expression } +type context_extras = { + ty_context_helpers : structure_item list; + ty_context_readback : structure_item list; +} + +type mutual_type_extras = { + ty_extras : type_extras list; + ctx_extras : context_extras option; +} + +let is_pred context name = + match context with None -> false | Some (n,_,_) -> n = name + let ctx_for k = function | None -> assert false | Some l -> @@ -297,30 +425,29 @@ let rec list_take i = function | _ :: _ when i = 0 -> [] | x :: xs -> x :: list_take (i-1) xs -let rec embed_k (module B : Ast_builder.S) ctx c all_kargs all_tmp kargs tmp tys n = let open B in +let rec embed_k (module B : Ast_builder.S) c all_kargs all_tmp kargs tmp tys n = let open B in match kargs, tmp, tys with | [], [], [] -> [%expr elpi__state, Elpi.API.RawData.mkAppL [%e c] [%e elist @@ List.map evar @@ List.map fst all_kargs], List.concat [%e elist all_tmp] ] - | (px,ex) :: xs, y :: ys, (FO { argFO_embed = t; _ }) :: ts -> [%expr + | (px,ex) :: xs, y :: ys, (FO { embed = t; _ }) :: ts -> [%expr let elpi__state, [%p pvar px], [%p pvar y] = [%e t] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state [%e ex] in - [%e embed_k (module B) ctx c all_kargs all_tmp xs ys ts (n+1)]] - | (px,ex) :: xs, y :: ys, HO{ argHO_build_ctx = f; argHO_embed = t; argHO_arrow_src = src; _ } :: ts -> + [%e embed_k (module B) c all_kargs all_tmp xs ys ts (n+1)]] + | (px,ex) :: xs, y :: ys, HO{ build_ctx = f; embed = t; ctx = ctx_name; _ } :: ts -> let xtmp = fresh () in - let ctx_name = ctx_for src ctx in let elpi_to_key = evar (elpi_to_key ctx_name) in let elpi_push = evar (elpi_push ctx_name) in let elpi_pop = evar (elpi_pop ctx_name) in [%expr let elpi__ctx_entry = [%e eapply f (List.map snd @@ list_take n all_kargs) ] in let elpi__ctx_key = [%e elpi_to_key ] ~depth: elpi__depth elpi__ctx_entry in - let elpi__ctx_entry = { Elpi.API.ContextualConversion.entry = elpi__ctx_entry; depth = elpi__depth } in + let elpi__ctx_entry = { Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = [%e elpi_push ] ~depth: (elpi__depth + 1) elpi__state elpi__ctx_key elpi__ctx_entry in let elpi__state, [%p pvar xtmp], [%p pvar y] = [%e t] ~depth: (elpi__depth + 1) elpi__hyps elpi__constraints elpi__state [%e ex] in let [%p pvar px] = Elpi.API.RawData.mkLam [%e evar xtmp] in let elpi__state = [%e elpi_pop ] ~depth: (elpi__depth + 1) elpi__state elpi__ctx_key in - [%e embed_k (module B) ctx c all_kargs all_tmp xs ys ts (n+1)]] + [%e embed_k (module B) c all_kargs all_tmp xs ys ts (n+1)]] | _ -> assert false ;; @@ -345,51 +472,49 @@ let abstract_standard_branch_embed (module B : Ast_builder.S) l e = let open B i in [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> [%e aux l ]] -let embed_branch (module B : Ast_builder.S) name (is_pred,ctx) = function +let embed_branch (module B : Ast_builder.S) is_pred = function | Skip { constructor_name; has_args } -> error_constructor_not_supported (module B) (constructor_name,has_args) - | Expose { constant; types; embed; pattern; _ } -> let open B in + | Expose { constant; arg_types; embed; pattern; _ } -> let open B in let pvl, pattern, types = - let pvl = List.map (fun _ -> fresh()) types in + let pvl = List.map (fun _ -> fresh()) arg_types in let kpattern = pattern (List.map pvar pvl) in if is_pred then let idx = fresh () in - idx :: pvl, ppat_tuple [pvar idx;kpattern], ctx_index_ty (module B) :: types - else pvl, kpattern, types in + idx :: pvl, ppat_tuple [pvar idx;kpattern], ctx_index_ty (module B) :: arg_types + else pvl, kpattern, arg_types in let standard = let evl = List.map (fun _ -> fresh()) types in let pvl2 = List.map (fun x -> fresh (), evar x) pvl in - embed_k (module B) ctx constant pvl2 (List.map evar evl) pvl2 evl types 0 in + embed_k (module B) constant pvl2 (List.map evar evl) pvl2 evl types 0 in case ~guard:None ~lhs:pattern ~rhs:begin match embed with - | Custom (e,_) -> - eapply [%expr [%e e] [%e abstract_standard_branch_embed (module B) pvl standard ] + | Custom { ml; _ } -> + eapply [%expr [%e ml] [%e abstract_standard_branch_embed (module B) pvl standard ] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state] (List.map evar pvl) | Standard -> standard - | Name p -> - let ctx_name = ctx_for name ctx in - embed_var (module B) ctx_name (List.map evar pvl) p + | Name { get_key; ctx_name } -> + embed_var (module B) ctx_name (List.map evar pvl) get_key end -let embed (module B : Ast_builder.S) name job kl = let open B in +let embed (module B : Ast_builder.S) is_pred kl = let open B in [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state -> - [%e pexp_function (List.map (embed_branch (module B) name job) kl) ]] + [%e pexp_function (List.map (embed_branch (module B) is_pred) kl) ]] -let readback_k (module B : Ast_builder.S) c ctx mk_k t ts = let open B in +let readback_k (module B : Ast_builder.S) c mk_k t ts = let open B in let one all_kargs n p1 e1 t x kont = match t with - | FO { argFO_readback = t; _ } -> [%expr + | FO { readback = t; _ } -> [%expr let elpi__state, [%p pvar p1], [%p pvar e1] = [%e t] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state [%e x] in [%e kont] ] - | HO { argHO_build_ctx = f; argHO_readback = t; argHO_arrow_src = src; _ } -> - let ctx_name = ctx_for src ctx in + | HO { build_ctx = f; readback = t; ctx = ctx_name; _ } -> let elpi_to_key = evar (elpi_to_key ctx_name) in let elpi_push = evar (elpi_push ctx_name) in let elpi_pop = evar (elpi_pop ctx_name) in [%expr let elpi__ctx_entry = [%e eapply f (List.map evar @@ list_take n all_kargs) ] in let elpi__ctx_key = [%e elpi_to_key ] ~depth: elpi__depth elpi__ctx_entry in - let elpi__ctx_entry = { Elpi.API.ContextualConversion.entry = elpi__ctx_entry; depth = elpi__depth } in + let elpi__ctx_entry = { Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = [%e elpi_push ] ~depth: elpi__depth elpi__state elpi__ctx_key elpi__ctx_entry in let elpi__state, [%p pvar p1], [%p pvar e1] = match Elpi.API.RawData.look ~depth: elpi__depth [%e x] with @@ -429,8 +554,8 @@ let readback_var (module B : Ast_builder.S) ctx_name constructor = let open B in if not (Elpi.API.RawData.Constants.Map.mem elpi__hd elpi__dbl2ctx) then Elpi.API.Utils.error (Format.asprintf "Unbound variable: %s in %a" (Elpi.API.RawData.Constants.show elpi__hd) - (Elpi.API.RawData.Constants.Map.pp (Elpi.API.ContextualConversion.pp_ctx_entry [%e evar ("pp_" ^ ctx_name)])) elpi__dbl2ctx); - let { Elpi.API.ContextualConversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd elpi__dbl2ctx in + (Elpi.API.RawData.Constants.Map.pp (Elpi.API.Conversion.pp_ctx_entry [%e evar ("pp_" ^ ctx_name)])) elpi__dbl2ctx); + let { Elpi.API.Conversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd elpi__dbl2ctx in elpi__state, [%e constructor [ [%expr [%e elpi_to_key ] ~depth: elpi__depth elpi__entry ] ] ], [] ] @@ -444,10 +569,10 @@ let abstract_standard_branch_readback2 (module B : Ast_builder.S) pos e = let op | elpi__x :: elpi__xs -> [%e e ] | [] -> Elpi.API.Utils.error ~loc: [%e elpi_loc_of_position (module B) pos ] "standard branch readback takes 1 argument or more"] -let readback_branch (module B : Ast_builder.S) name (is_pred,ctx) { constant; constructor; types; readback; _ } = let open B in +let readback_branch (module B : Ast_builder.S) is_pred { constant; constructor; arg_types; readback; _ } = let open B in let types, mk_k = - if is_pred then ctx_index_ty (module B) :: types, (function x :: xs -> pexp_tuple [x;constructor xs] | [] -> assert false) - else types, constructor in + if is_pred then ctx_index_ty (module B) :: arg_types, (function x :: xs -> pexp_tuple [x;constructor xs] | [] -> assert false) + else arg_types, constructor in match types with | [] -> let standard = [%expr elpi__state, [%e constructor [] ], []] in @@ -455,22 +580,21 @@ let readback_branch (module B : Ast_builder.S) name (is_pred,ctx) { constant; co ~guard:(Some [%expr elpi__hd == [%e constant]]) ~rhs:begin match readback with | Standard -> standard - | Custom(e,pos) -> [%expr [%e e] [%e abstract_standard_branch_readback (module B) pos standard] ~depth: elpi__depth elpi__hyps elpi__constraints [] ] + | Custom { ml; pos } -> [%expr [%e ml] [%e abstract_standard_branch_readback (module B) pos standard] ~depth: elpi__depth elpi__hyps elpi__constraints [] ] | Name _ -> assert false end | t :: ts -> - let standard = readback_k (module B) constant ctx mk_k t ts in + let standard = readback_k (module B) constant mk_k t ts in match readback with | Standard -> case ~lhs:[%pat? Elpi.API.RawData.App (elpi__hd,elpi__x,elpi__xs)] ~guard:(Some [%expr elpi__hd == [%e constant]]) ~rhs:standard - | Custom(e,pos) -> + | Custom { ml; pos } -> case ~lhs:[%pat? Elpi.API.RawData.App (elpi__hd,elpi__x,elpi__xs)] ~guard:(Some [%expr elpi__hd == [%e constant]]) - ~rhs:([%expr [%e e] [%e abstract_standard_branch_readback2 (module B) pos standard ] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state (elpi__x :: elpi__xs)]) - | Name _ -> assert(ts = []); - let ctx_name = ctx_for name ctx in + ~rhs:([%expr [%e ml] [%e abstract_standard_branch_readback2 (module B) pos standard ] ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state (elpi__x :: elpi__xs)]) + | Name { ctx_name; _} -> assert(ts = []); case ~lhs:[%pat? Elpi.API.RawData.Const elpi__hd] ~guard:(Some [%expr elpi__hd >= 0]) ~rhs:(readback_var (module B) ctx_name constructor) @@ -478,10 +602,10 @@ let readback_branch (module B : Ast_builder.S) name (is_pred,ctx) { constant; co let abstract_standard_default_readback (module B : Ast_builder.S) e = let open B in [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state elpi__x -> [%e e]] -let readback (module B : Ast_builder.S) name job default_readback kl = let open B in +let readback (module B : Ast_builder.S) name is_pred default_readback kl = let open B in [%expr fun ~depth: elpi__depth elpi__hyps elpi__constraints elpi__state elpi__x -> [%e pexp_match [%expr Elpi.API.RawData.look ~depth: elpi__depth elpi__x] - (List.map (readback_branch (module B) name job) (drop_skip kl) @ + (List.map (readback_branch (module B) is_pred) (drop_skip kl) @ [case ~guard:None ~lhs:[%pat? _ ] ~rhs:begin let standard = @@ -493,21 +617,22 @@ let readback (module B : Ast_builder.S) name job default_readback kl = let open end])]] let ctx_entry_key (module B : Ast_builder.S) kl = let open B in - let project { pattern; types; _ } = - let pvl = List.map (function FO { argFO_key = true; _ } -> fresh() | _ -> "_") types in + let project { pattern; arg_types; _ } = + let pvl = List.map (function FO { key = true; _ } -> fresh() | _ -> "_") arg_types in let rec find_key vl tl = match vl, tl with - | v :: _, FO { argFO_key = true; _ } :: _ -> evar v + | v :: _, FO { key = true; _ } :: _ -> evar v | _ :: vs, _ :: ts -> find_key vs ts | _ -> assert false in - case ~lhs:(pattern (List.map pvar pvl)) ~guard:None ~rhs:(find_key pvl types) in + case ~lhs:(pattern (List.map pvar pvl)) ~guard:None ~rhs:(find_key pvl arg_types) in [%expr fun ~depth:_ -> [%e pexp_function ( List.map project (drop_skip kl) @ List.map (error_constructor_not_supported (module B)) (keep_skip kl)) ] ] let is_ctx_entry (module B : Ast_builder.S) kl = let open B in - [%expr fun ~depth: elpi__depth elpi__x -> match Elpi.API.RawData.look ~depth: elpi__depth elpi__x with + [%expr fun { Elpi.API.Data.hdepth = elpi__depth; hsrc = elpi__x } -> + match Elpi.API.RawData.look ~depth: elpi__depth elpi__x with | Elpi.API.RawData.Const _ -> None | Elpi.API.RawData.App(elpi__hd,elpi__idx,_) -> if [%e @@ -522,7 +647,7 @@ let is_ctx_entry (module B : Ast_builder.S) kl = let open B in | _ -> Elpi.API.Utils.type_error "context entry applied to a non nominal" else None | _ -> None ] - +(* let ctx_readback (module B : Ast_builder.S) name = let open B in let elpi_Map = elpi_Map ~loc name in let elpi_push = evar (elpi_push name) in @@ -549,10 +674,10 @@ let ctx_readback (module B : Ast_builder.S) name = let open B in let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in let elpi__state, (elpi__nominal, elpi__t), elpi__gls_t = - [%e evar name].Elpi.API.ContextualConversion.readback ~depth: elpi__hyp_depth elpi__hyps elpi__constraints elpi__state elpi__hyp.Elpi.API.RawData.hsrc in + [%e evar name].Elpi.API.Conversion.readback ~depth: elpi__hyp_depth elpi__hyps elpi__constraints elpi__state elpi__hyp.Elpi.API.RawData.hsrc in assert(elpi__nominal = elpi__i); let elpi__s = [%e elpi_to_key ] ~depth: elpi__hyp_depth elpi__t in - let elpi__state = [%e elpi_push ] ~depth:elpi__i elpi__state elpi__s { Elpi.API.ContextualConversion.entry = elpi__t; depth = elpi__hyp_depth } in + let elpi__state = [%e elpi_push ] ~depth:elpi__i elpi__state elpi__s { Elpi.API.Conversion.entry = elpi__t; depth = elpi__hyp_depth } in elpi__aux elpi__state (elpi__gls_t :: elpi__gls) (elpi__i+1) in let elpi__state = Elpi.API.State.set [%e elpi_state_component ] elpi__state ([%e elpi_Map "empty" ], CMap.empty) in @@ -564,9 +689,12 @@ let rec compose_ctx_readback (module B : Ast_builder.S) = function | [] -> assert false | [x] -> B.evar (elpi_in_name_alone x) | x :: xs -> let open B in - [%expr Elpi.API.ContextualConversion.(|+|) + [%expr Elpi.API.Conversion.(|+|) [%e evar (elpi_in_name_alone x) ] [%e compose_ctx_readback (module B) xs] ] +*) + + let ctx_push (module B : Ast_builder.S) name = let open B in let elpi_Map = elpi_Map ~loc name in @@ -592,14 +720,14 @@ let rec fmap f = function [] -> [] | x :: xs -> match f x with None -> fmap f xs let conversion_of (module B : Ast_builder.S) ty = let open B in let rec aux = function - | [%type: string] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.string] - | [%type: int] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.int] - | [%type: float] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.float] - | [%type: bool] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool] - | [%type: char] -> [%expr Elpi.API.ContextualConversion.(!>) Elpi.Builtin.char] - | [%type: [%t? typ] list] -> [%expr Elpi.API.ContextualConversion.(!>>) Elpi.API.BuiltInData.list [%e aux typ ]] - | [%type: [%t? typ] option] -> [%expr Elpi.API.ContextualConversion.(!>>) Elpi.Builtin.option [%e aux typ ]] - | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.API.ContextualConversion.(!>>>) Elpi.Builtin.pair [%e aux typ1 ] [%e aux typ2 ]] + | [%type: string] -> [%expr Elpi.API.BuiltInData.string] + | [%type: int] -> [%expr Elpi.API.BuiltInData.int] + | [%type: float] -> [%expr Elpi.API.BuiltInData.float] + | [%type: bool] -> [%expr Elpi.Builtin.bool] + | [%type: char] -> [%expr Elpi.Builtin.char] + | [%type: [%t? typ] list] -> [%expr Elpi.API.BuiltInData.list [%e aux typ ]] + | [%type: [%t? typ] option] -> [%expr Elpi.Builtin.option [%e aux typ ]] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.Builtin.pair [%e aux typ1 ] [%e aux typ2 ]] | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.Builtin.triple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ]] | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.Builtin.quadruple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ]] | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.Builtin.quintuple [%e aux typ1 ] [%e aux typ2 ] [%e aux typ3 ] [%e aux typ4 ] [%e aux typ5 ]] @@ -630,7 +758,7 @@ let rec find_embed_of (module B : Ast_builder.S) current_mutrec_block ty = let | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, params); _ } when List.mem id current_mutrec_block || is_parameter id -> eapply (evar (elpi_embed_name id)) (List.map (find_embed_of (module B) current_mutrec_block) params) - | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.ContextualConversion.embed ] + | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.Conversion.embed ] in aux ty @@ -651,7 +779,7 @@ let rec find_readback_of (module B : Ast_builder.S) current_mutrec_block ty = l | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, params); _ } when List.mem id current_mutrec_block || is_parameter id -> eapply (evar (elpi_readback_name id)) (List.map (find_readback_of (module B) current_mutrec_block) params) - | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.ContextualConversion.readback ] + | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.Conversion.readback ] in aux ty @@ -659,17 +787,17 @@ let rec find_ty_ast_of (module B : Ast_builder.S) current_mutrec_block ty = let match ty with | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, []); _ } when List.mem id current_mutrec_block -> - [%expr Elpi.API.ContextualConversion.TyName([%e evar @@ elpi_tname_str id])] + [%expr Elpi.API.Conversion.TyName([%e evar @@ elpi_tname_str id])] | { ptyp_desc = Ptyp_constr ({ txt = Longident.Lident id; _ }, p::ps); _ } when List.mem id current_mutrec_block -> - [%expr Elpi.API.ContextualConversion.TyApp([%e evar @@ elpi_tname_str id],[%e find_ty_ast_of (module B) current_mutrec_block p],[%e elist @@ List.map (find_ty_ast_of (module B) current_mutrec_block) ps ])] - | [%type: [%t? typ] list] -> [%expr Elpi.API.ContextualConversion.TyApp("list", [%e find_ty_ast_of (module B) current_mutrec_block typ ], [])] - | [%type: [%t? typ] option] -> [%expr Elpi.API.ContextualConversion.TyApp("option", [%e find_ty_ast_of (module B) current_mutrec_block typ ], [])] - | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.API.ContextualConversion.TyApp("pair", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ] ])] - | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.API.ContextualConversion.TyApp("triple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ] ])] - | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.API.ContextualConversion.TyApp("quadruple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ4 ] ])] - | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.API.ContextualConversion.TyApp("quintuple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ4 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ5 ] ])] - | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.ContextualConversion.ty ] + [%expr Elpi.API.Conversion.TyApp([%e evar @@ elpi_tname_str id],[%e find_ty_ast_of (module B) current_mutrec_block p],[%e elist @@ List.map (find_ty_ast_of (module B) current_mutrec_block) ps ])] + | [%type: [%t? typ] list] -> [%expr Elpi.API.Conversion.TyApp("list", [%e find_ty_ast_of (module B) current_mutrec_block typ ], [])] + | [%type: [%t? typ] option] -> [%expr Elpi.API.Conversion.TyApp("option", [%e find_ty_ast_of (module B) current_mutrec_block typ ], [])] + | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.API.Conversion.TyApp("pair", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ] ])] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3]] -> [%expr Elpi.API.Conversion.TyApp("triple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ] ])] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4]] -> [%expr Elpi.API.Conversion.TyApp("quadruple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ4 ] ])] + | [%type: [%t? typ1] * [%t? typ2] * [%t? typ3] * [%t? typ4] * [%t? typ5]] -> [%expr Elpi.API.Conversion.TyApp("quintuple", [%e find_ty_ast_of (module B) current_mutrec_block typ1 ], [ [%e find_ty_ast_of (module B) current_mutrec_block typ2 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ3 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ4 ]; [%e find_ty_ast_of (module B) current_mutrec_block typ5 ] ])] + | t -> [%expr [%e conversion_of (module B) t ].Elpi.API.Conversion.ty ] let find_mapper_of (module B : Ast_builder.S) current_mutrec_block params ty = let open B in let rec aux ty = @@ -691,13 +819,17 @@ let find_mapper_of (module B : Ast_builder.S) current_mutrec_block params ty = l fun (v1,v2) -> [%expr "(" ^ [%e aux ty] ^ " " ^ [%e estring v1 ] ^ " " ^[%e estring v2 ] ^ ")" ] ;; +let one_lident = function + | { pexp_desc = Pexp_ident { txt = Lident x ; _ }; _ } -> Some x + | _ -> None + let one_string = function | { pexp_desc = Pexp_constant (Pconst_string(s,_)); _ } -> Some s | _ -> None let one_or_two_strings (module B : Ast_builder.S) = function | Pexp_constant (Pconst_string (s,_)) -> s, None - | Pexp_apply(x,[_,y]) when is_some (one_string x) && is_some (one_string y) -> + | Pexp_apply(x,[_,y]) when option_is_some (one_string x) && option_is_some (one_string y) -> option_get (one_string x), one_string y | _ -> error "string or ident expected" @@ -715,10 +847,26 @@ let get_elpi_doc kname kattributes = option_default kname (Attribute.get att_elpi_doc kattributes) let get_elpi_tdoc kname kattributes = option_default kname (Attribute.get att_elpi_tdoc kattributes) -let get_elpi_treadback tattributes = - Attribute.get att_elpi_treadback tattributes +let get_elpi_tdefkreadback tattributes = + Attribute.get att_elpi_def_k_readback tattributes let get_elpi_pp tattributes = - Attribute.get att_elpi_pp tattributes + Attribute.get att_elpi_tpp tattributes +let get_elpi_tindex tattributes = + Attribute.get att_elpi_tindex tattributes +let get_elpi_tcdata ~loc tattributes = + match Attribute.get att_elpi_tcdata tattributes with + | None -> error ~loc "opaque data types must have a [@@elpi.opaque d] attribute" + | Some c -> c +let has_elpi_tcdata tattributes = + option_is_some (Attribute.get att_elpi_tcdata tattributes) + +let parse_lident_list (module B : Ast_builder.S) = let open B in + let rec aux = function + | [%expr [] ] -> [] + | [%expr [%e? { pexp_desc = Pexp_ident { txt = Lident id; _}; _} ] :: [%e? tl ] ] -> id :: aux tl + | _ -> error ~loc "ident expected" + in + aux let analyze_tuple_constructor (module B : Ast_builder.S) tyname kname kattributes tl constructor pattern same_mutrec_block = let open B in let c_str = elpi_kname_str tyname kname in @@ -728,60 +876,73 @@ let analyze_tuple_constructor (module B : Ast_builder.S) tyname kname kattribute let decl_str = value_binding ~pat:(pvar c_str) ~expr:(estring str) in let decl = value_binding ~pat:(pvar c) ~expr:[%expr Elpi.API.RawData.Constants.declare_global_symbol [%e evar @@ c_str ] ] in let tl = - tl |> List.map (fun t -> - match Attribute.get att_elpi_binder t with - | Some { pexp_desc = Pexp_apply({ pexp_desc = Pexp_ident { txt; _}; _},[_,arg]) ; _ } -> + tl |> List.map (fun ty -> + match Attribute.get att_elpi_binder ty with + | Some [%expr [%e? { pexp_desc = Pexp_constant (Pconst_string(arrow_src_elpi,None)); _}] [%e? { pexp_desc = Pexp_ident { txt = Lident ctx; _}; _}] [%e? build_ctx] ] -> HO { - argHO_arrow_src = String.concat "." @@ Longident.flatten_exn txt; - argHO_build_ctx = arg; - argHO_readback = find_readback_of (module B) same_mutrec_block t; - argHO_embed = find_embed_of (module B) same_mutrec_block t; - argHO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; - argHO_ty = t; + ty; ctx; build_ctx; arrow_src_elpi; + readback = find_readback_of (module B) same_mutrec_block ty; + embed = find_embed_of (module B) same_mutrec_block ty; + ty_ast = find_ty_ast_of (module B) same_mutrec_block ty; } - | Some { pexp_desc = Pexp_apply({ pexp_desc = Pexp_constant (Pconst_string(txt,_)); _},[_,arg]) ; _ } -> + | Some [%expr [%e? { pexp_desc = Pexp_ident { txt = Lident ctx; _}; _}] [%e? build_ctx] ] -> HO { - argHO_arrow_src = txt; - argHO_build_ctx = arg; - argHO_readback = find_readback_of (module B) same_mutrec_block t; - argHO_embed = find_embed_of (module B) same_mutrec_block t; - argHO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; - argHO_ty = t; + ty; ctx; build_ctx; arrow_src_elpi = tyname; + readback = find_readback_of (module B) same_mutrec_block ty; + embed = find_embed_of (module B) same_mutrec_block ty; + ty_ast = find_ty_ast_of (module B) same_mutrec_block ty; } - | Some e -> - HO{ - argHO_arrow_src = tyname; - argHO_build_ctx = e; - argHO_readback = find_readback_of (module B) same_mutrec_block t; - argHO_embed = find_embed_of (module B) same_mutrec_block t; - argHO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; - argHO_ty = t; - } + | Some _ -> error ~loc "use [@elpi.binder \"ty\" ctx mk_ctx_entry]" | None -> - let argFO_key = None <> Attribute.get att_elpi_key t in + let key = None <> Attribute.get att_elpi_key ty in FO { - argFO_readback = find_readback_of (module B) same_mutrec_block t; - argFO_embed = find_embed_of (module B) same_mutrec_block t; - argFO_key; - argFO_ty_ast = find_ty_ast_of (module B) same_mutrec_block t; - argFO_ty = t; + ty; key; + readback = find_readback_of (module B) same_mutrec_block ty; + embed = find_embed_of (module B) same_mutrec_block ty; + ty_ast = find_ty_ast_of (module B) same_mutrec_block ty; }) in + let var_ = + match Attribute.get att_elpi_var kattributes with + | Some [%expr [%e? ctx_name ] [%e? get_key ]] when option_is_some (one_lident ctx_name) -> + Some (Name { get_key; ctx_name = option_get (one_lident ctx_name) }) + | Some [%expr [%e? ctx_name] ] when option_is_some (one_lident ctx_name) -> + Some (Name { get_key = [%expr fun x -> x]; ctx_name = option_get (one_lident ctx_name) }) + | Some _ -> error ~loc "use [@elpi.var ctx to_key]" + | None -> None in let readback = Attribute.get att_elpi_readback kattributes in let embed = Attribute.get att_elpi_embed kattributes in let readback, embed = - let var_ = option_map (option_default [%expr fun x -> x]) (Attribute.get att_elpi_var kattributes) in - let opt2custom = function None -> Standard | Some x -> Custom(x,B.loc.loc_end) in + let opt2custom = function None -> Standard | Some ml -> Custom { ml; pos = B.loc.loc_end } in match readback, embed, var_ with | _, _, None -> opt2custom readback, opt2custom embed | None, None, Some p -> - if List.length tl = 1 then Name p, Name p + if List.length tl = 1 then p, p else error "[@elpi.var] on a constructor with zero or more than one argument and not [@elpi.readback]" | None, (Some _ as e), Some p -> - if List.length tl = 1 then Name p, opt2custom e + if List.length tl = 1 then p, opt2custom e else error "[@elpi.var] on a constructor with more than one argument and not [@elpi.readback]" - | (Some _ as r), None, Some p -> opt2custom r, Name p + | (Some _ as r), None, Some p -> opt2custom r, p | Some _, Some _, Some _ -> error "[@elpi.var] on a constructor with [@elpi.readback] and [@elpi.embed]" in - Expose { declaration = [pstr_value Nonrecursive [decl_str]; pstr_value Nonrecursive [decl]] ; constant = evar c; constant_name = str; elpi_code = option_map estring elpi_code; elpi_doc; types = tl; constructor; pattern; embed; readback } + let ctx_names_of_directive = function + | Custom _ -> [] + | Standard -> [] + | Name { ctx_name; _ } -> [ctx_name] in + let ctx_names = + List.concat (ctx_names_of_directive embed :: ctx_names_of_directive readback :: + List.map (function HO { ctx; _ } -> [ctx] | _ -> []) tl) in + Expose { + declaration = [pstr_value Nonrecursive [decl_str]; pstr_value Nonrecursive [decl]] ; + constant = evar c; + constant_name = str; + elpi_code = option_map estring elpi_code; + elpi_doc; + arg_types = tl; + constructor; + pattern; + embed; + readback; + ctx_names; + } ;; let analyze_constructor (module B : Ast_builder.S) tyname same_mutrec_block decl = let open B in @@ -820,34 +981,35 @@ let analyze_params (module B : Ast_builder.S) params = let open B in List.map ((^) param_prefix) tyvars, mapper let mk_kind (module B : Ast_builder.S) vl name = let open B in - match List.map (fun x -> [%expr [%e evar x ].Elpi.API.ContextualConversion.ty]) vl with - | [] -> [%expr Elpi.API.ContextualConversion.TyName [%e name ]] - | x :: xs -> [%expr Elpi.API.ContextualConversion.TyApp([%e name], [%e x], [%e elist @@ xs])] - -let consistency_check ~loc (tyd,kind) = - let name, csts = - match tyd with - | { name; type_decl = Algebraic (l,_); _ } -> name, drop_skip l - | { name; _ } -> name, [] in - let some_have_key = - List.exists (fun { types; _ } -> List.exists is_key types) csts in - let some_have_under = - List.exists (fun { types; _ } -> List.exists is_HO types) csts in - let all_have_1_key = - List.for_all (fun { types; _ } -> - 1 = List.(length (filter is_key types))) csts in - let some_k_is_var = - List.exists (function { embed = Name _; _ } | { readback = Name _; _ } -> true | _ -> false) csts in - match kind with - | ADT when some_have_key || some_k_is_var || some_have_under-> - error ~loc "type %s is a simple ADT but uses [@elpi.var] or [@elpi.key] or [@elpi.binder]. Use [@@elpi : type] to make it a HOADT or [@@elpi (module M)] to make it a context ADT" name - | CTX _ when not all_have_1_key -> - error ~loc "type %s is a context ADT but has a constructor that does not have exactly one argumet marked as [@elpi.key]" name - | CTX _ when tyd.params <> [] -> - error ~loc "type %s is a context ADT but has parameters, not supported" name - | HOAS _ when not (some_k_is_var || some_have_under) -> - error ~loc "type %s is a HOADT but has no constructor flagged as [@elpi.var] nor arguments flagged as [@elpi.binder]" name - | _ -> () + match List.map (fun x -> [%expr [%e evar x ].Elpi.API.Conversion.ty]) vl with + | [] -> [%expr Elpi.API.Conversion.TyName [%e name ]] + | x :: xs -> [%expr Elpi.API.Conversion.TyApp([%e name], [%e x], [%e elist @@ xs])] + +let consistency_check ~loc tyds = + let context = ref None in + List.iter (fun tyd -> + let name, csts = + match tyd with + | { name; type_decl = Algebraic (l,_); _ } -> name, drop_skip l + | { name; _ } -> name, [] in + let some_have_key = + List.exists (fun { arg_types; _ } -> List.exists is_key arg_types) csts in + let all_have_1_key = + List.for_all (fun { arg_types; _ } -> + 1 = List.(length (filter is_key arg_types))) csts in + match tyd.index with + | None when some_have_key -> + error ~loc "type %s has [@elpi.key] but no index was provided. Use [@@elpi { index = (module M) }]" name + | Some _ when some_have_key && (not all_have_1_key) -> + error ~loc "type %s has constructor that does not have exactly one argumet marked as [@elpi.key]" name + | Some _ when all_have_1_key && tyd.params <> [] -> + error ~loc "type %s has [@elpi.key] but has parameters, not supported" name + | Some _ when !context <> None -> + let other, _, _ = option_get !context in + error ~loc "both %s and %s have [@elpi.key], not supported" name other + | Some m when all_have_1_key -> context := Some (name,m,tyd) + | _ -> ()) tyds; + !context ;; let pp_doc (module B : Ast_builder.S) kind elpi_name elpi_code elpi_doc is_pred csts = let open B in [%expr fun fmt () -> @@ -860,10 +1022,10 @@ let pp_doc (module B : Ast_builder.S) kind elpi_name elpi_code elpi_doc is_pred [%e elpi_name ] [%e code ] ] ] ; [%e esequence @@ - List.(concat @@ (drop_skip csts |> map (fun { constant_name = c; types; embed; readback; elpi_code; elpi_doc; _ } -> + List.(concat @@ (drop_skip csts |> map (fun { constant_name = c; arg_types; embed; readback; elpi_code; elpi_doc; _ } -> let types, ty = - if is_pred then ctx_index_ty (module B) :: types, [%expr Elpi.API.ContextualConversion.TyName "prop"] - else types, [%expr kind ] in + if is_pred then ctx_index_ty (module B) :: arg_types, [%expr Elpi.API.Conversion.TyName "prop"] + else arg_types, [%expr kind ] in if is_name embed || is_name readback then [] else [ match elpi_code with @@ -875,11 +1037,11 @@ let pp_doc (module B : Ast_builder.S) kind elpi_name elpi_code elpi_doc is_pred ~name:[%e estring c] ~doc:[%e estring elpi_doc ] ~args:[%e elist @@ List.map (function - | FO { argFO_ty_ast; _ } -> argFO_ty_ast - | HO { argHO_arrow_src = s; argHO_ty_ast; _ } -> - [%expr Elpi.API.ContextualConversion.TyApp("->", - Elpi.API.ContextualConversion.TyName [%e estring s], - [[%e argHO_ty_ast]]) ] + | FO { ty_ast; _ } -> ty_ast + | HO { arrow_src_elpi = s; ty_ast; _ } -> + [%expr Elpi.API.Conversion.TyApp("->", + Elpi.API.Conversion.TyName [%e estring s], + [[%e ty_ast]]) ] ) types] ]]))) ]] @@ -891,7 +1053,7 @@ let typeabbrev_for (module B : Ast_builder.S) f params = let open B in if params = [] then f else [%expr "(" ^ [%e f] ^ " " ^ [%e estring (String.concat " " vars) ] ^")" ] let typeabbrev_for_conv (module B : Ast_builder.S) ct = let open B in - [%expr Elpi.API.PPX.Doc.show_ty_ast ~outer: false @@ [%e conversion_of (module B) ct].Elpi.API.ContextualConversion.ty ] + [%expr Elpi.API.PPX.Doc.show_ty_ast ~outer: false @@ [%e conversion_of (module B) ct].Elpi.API.Conversion.ty ] let mk_pp_name (module B : Ast_builder.S) name = function | None -> if name = "t" then B.evar "pp" else B.evar ("pp_" ^ name) @@ -905,101 +1067,200 @@ let pp_for_conversion (module B : Ast_builder.S) name is_pred params pp = let op let quantify_ty_over_params (module B : Ast_builder.S) params t = let open B in ptyp_poly (List.map Located.mk params) t -let conversion_type (module B : Ast_builder.S) name params is_pred = let open B in +let ctx_obj (module B : Ast_builder.S) name is_pred all_ctx = let open B in + ptyp_poly [] (ptyp_class (Located.lident (elpi_ctx_class_name name)) []) + +let conversion_type (module B : Ast_builder.S) name params is_pred all_ctx = let open B in let rec aux = function | [] -> let t = ptyp_constr (Located.lident name) (List.map ptyp_var params) in let t = if is_pred then ptyp_tuple [ [%type: Elpi.API.RawData.constant ] ;t] else t in - [%type: ([%t t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.t] - | t :: ts -> [%type: ([%t ptyp_var t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.t -> [%t aux ts]] + [%type: ([%t t ],[%t ctx_obj (module B) name is_pred all_ctx ] as 'c) Elpi.API.Conversion.t] + | t :: ts -> [%type: ([%t ptyp_var t ], 'c ) Elpi.API.Conversion.t -> [%t aux ts]] in - quantify_ty_over_params (module B) (params @ ["elpi__param__poly_hyps"; "elpi__param__poly_csts"]) (aux params) + quantify_ty_over_params (module B) (params @ ["c"]) (aux params) -let readback_type (module B : Ast_builder.S) name params is_pred = let open B in +let readback_type (module B : Ast_builder.S) name params is_pred all_ctx = let open B in let rec aux = function | [] -> let t = ptyp_constr (Located.lident name) (List.map ptyp_var params) in let t = if is_pred then ptyp_tuple [ [%type: Elpi.API.RawData.constant ] ;t] else t in - [%type: ([%t t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback] - | t :: ts -> [%type: ([%t ptyp_var t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback -> [%t aux ts]] + [%type: ([%t t ], [%t ctx_obj (module B) name is_pred all_ctx ] as 'c) Elpi.API.Conversion.readback] + | t :: ts -> [%type: ([%t ptyp_var t ],'c) Elpi.API.Conversion.readback -> [%t aux ts]] in - quantify_ty_over_params (module B) (params @ ["elpi__param__poly_hyps"; "elpi__param__poly_csts"]) (aux params) + quantify_ty_over_params (module B) (params @ ["c"]) (aux params) -let embed_type (module B : Ast_builder.S) name params is_pred = let open B in +let embed_type (module B : Ast_builder.S) name params is_pred all_ctx = let open B in let rec aux = function | [] -> let t = ptyp_constr (Located.lident name) (List.map ptyp_var params) in let t = if is_pred then ptyp_tuple [ [%type: Elpi.API.RawData.constant ] ;t] else t in - [%type: ([%t t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding] - | t :: ts -> [%type: ([%t ptyp_var t ],'elpi__param__poly_hyps,'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding -> [%t aux ts]] + [%type: ([%t t ], [%t ctx_obj (module B) name is_pred all_ctx ] as 'c) Elpi.API.Conversion.embedding] + | t :: ts -> [%type: ([%t ptyp_var t ],'c) Elpi.API.Conversion.embedding -> [%t aux ts]] in - quantify_ty_over_params (module B) (params @ ["elpi__param__poly_hyps"; "elpi__param__poly_csts"]) (aux params) - - -let coversion_for_opaque (module B : Ast_builder.S) elpi_name name pp = let open B in - value_binding ~pat:(ppat_constraint (pvar name) [%type: [%t ptyp_constr (Located.lident name) []] Elpi.API.Conversion.t]) ~expr:[%expr - Elpi.API.OpaqueData.declare { - Elpi.API.OpaqueData.name = [%e elpi_name ] ; - doc = ""; - pp = ([%e mk_pp_name (module B) name pp ]); - compare = Pervasives.compare; - hash = Hashtbl.hash; - hconsed = false; - constants = []; - } + quantify_ty_over_params (module B) (params @ ["c"]) (aux params) + + +let coversion_for_opaque (module B : Ast_builder.S) elpi_name name = let open B in + value_binding ~pat:(ppat_constraint (pvar name) + (quantify_ty_over_params (module B) ["c"] + [%type: ( [%t ptyp_constr (Located.lident name) []] , #Elpi.API.Conversion.ctx as 'c) Elpi.API.Conversion.t])) + ~expr:[%expr + + let name = [%e elpi_name ] in + let { Elpi.API.RawOpaqueData.cin; isc; cout; name=c }, constants_map, doc = [%e evar @@ elpi_cdata_name name ] in + + let ty = Elpi.API.Conversion.TyName name in + let embed ~depth:_ _ _ state x = + state, Elpi.API.RawData.mkCData (cin x), [] in + let readback ~depth _ _ state t = + match Elpi.API.RawData.look ~depth t with + | Elpi.API.RawData.CData c when isc c -> state, cout c, [] + | Elpi.API.RawData.Const i when i < 0 -> + begin try state, snd @@ Elpi.API.RawData.Constants.Map.find i constants_map, [] + with Not_found -> raise (Elpi.API.Conversion.TypeErr(ty,depth,t)) end + | _ -> raise (Elpi.API.Conversion.TypeErr(ty,depth,t)) in + let pp_doc fmt () = + if doc <> "" then begin + Elpi.API.PPX.Doc.comment fmt ("% " ^ doc); + Format.fprintf fmt "@\n"; + end; + Format.fprintf fmt "@[typeabbrev %s (ctype \"%s\").@]@\n@\n" name c; + Elpi.API.RawData.Constants.Map.iter (fun _ (c,_) -> + Format.fprintf fmt "@[type %s %s.@]@\n" c name) + constants_map + in + { Elpi.API.Conversion.embed; readback; ty; pp_doc; pp = (fun fmt x -> Elpi.API.RawOpaqueData.pp fmt (cin x)) } + ] -let conversion_for_alias (module B : Ast_builder.S) orig name params _same_mutrec_block = let open B in - let conv = conversion_of (module B) orig in - value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params false)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) conv) +let abstract_expr_over_params (module B : Ast_builder.S) vl f e = let open B in + let rec aux = function + | [] -> e + | v :: vs -> [%expr fun [%p pvar (f v) ] -> [%e aux vs]] + in + aux vl -let conversion_for_tyd (module B : Ast_builder.S) is_pred _same_mutrec_block { name; params; elpi_name; elpi_code; elpi_doc; type_decl; pp } = let open B in +let ctx_class_type_for_tyd (module B : Ast_builder.S) all_ctx { name; _ } = let open B in + pstr_module @@ module_binding ~name:(Located.mk (elpi_ctx_class_module_name name)) ~expr:(pmod_structure [ + pstr_class_type [class_infos ~virt:Concrete ~params:[] + ~name:(Located.mk "t") + ~expr:(pcty_signature @@ class_signature ~self:[%type: _] ~fields:( + (pctf_inherit (pcty_constr (Located.lident "Elpi.API.Conversion.ctx") [])) + :: List.flatten (SSet.elements all_ctx |> List.(map (fun c -> + [ + pctf_inherit (pcty_constr (Located.lident @@ elpi_ctx_class_name c) []); + pctf_method (Located.mk c,Public,Concrete,[%type: [%t ptyp_constr (Located.lident c) [] ] Elpi.API.Conversion.ctx_field]); + ])))))] + ]) + +let conversion_for_tyd (module B : Ast_builder.S) all_ctx { name; params; elpi_name; elpi_code; elpi_doc; type_decl; pp; index } = let open B in + let is_pred = option_is_some index in match type_decl with - | Opaque -> coversion_for_opaque (module B) (estring elpi_name) name pp + | Opaque _ -> + pstr_value Nonrecursive [coversion_for_opaque (module B) (estring elpi_name) name] | Alias _ -> - value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params is_pred)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) ([%expr + pstr_value Nonrecursive [value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params is_pred all_ctx)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) ([%expr let kind = [%e mk_kind (module B) params (estring elpi_name) ] in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = [%e pp_doc (module B) [%expr kind] (estring elpi_name) (option_map estring elpi_code) elpi_doc is_pred [] ]; pp = [%e pp_for_conversion (module B) name is_pred params pp ]; - embed = [%e eapply (evar (elpi_embed_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.embed]) params) ]; - readback = [%e eapply (evar (elpi_readback_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.readback]) params) ]; - }])) + embed = [%e eapply (evar (elpi_embed_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.Conversion.embed]) params) ]; + readback = [%e eapply (evar (elpi_readback_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.Conversion.readback]) params) ]; + }]))] | Algebraic(csts,_)-> - value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params is_pred)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) ([%expr - let kind = [%e mk_kind (module B) params (estring elpi_name) ] in - { - Elpi.API.ContextualConversion.ty = kind; - pp_doc = [%e pp_doc (module B) [%expr kind] (estring elpi_name) (option_map estring elpi_code) elpi_doc is_pred csts ]; - pp = [%e pp_for_conversion (module B) name is_pred params pp ]; - embed = [%e eapply (evar (elpi_embed_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.embed]) params) ]; - readback = [%e eapply (evar (elpi_readback_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.ContextualConversion.readback]) params) ]; - }])) + pstr_value Nonrecursive [value_binding ~pat:(ppat_constraint (pvar name) (conversion_type (module B) name params is_pred all_ctx)) ~expr:(abstract_expr_over_params (module B) params (fun x -> x) ([%expr + let kind = [%e mk_kind (module B) params (estring elpi_name) ] in + { + Elpi.API.Conversion.ty = kind; + pp_doc = [%e pp_doc (module B) [%expr kind] (estring elpi_name) (option_map estring elpi_code) elpi_doc is_pred csts ]; + pp = [%e pp_for_conversion (module B) name is_pred params pp ]; + embed = [%e eapply (evar (elpi_embed_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.Conversion.embed]) params) ]; + readback = [%e eapply (evar (elpi_readback_name name)) (List.map (fun x -> [%expr [%e evar x].Elpi.API.Conversion.readback]) params) ]; + }]))] ;; -let embed_for_tyd (module B : Ast_builder.S) (is_pred,ctx) same_mutrec_block { name; params; type_decl; _ } = let open B in +let initial_state (module B : Ast_builder.S) name = let open B in + let elpi_Map = elpi_Map ~loc name in [%expr + ( [%e elpi_Map "empty" ] : [%t ptyp_constr (Located.lident (elpi_map_name name ^ ".t")) [ [%type: Elpi.API.RawData.constant] ] ]) + , + (Elpi.API.RawData.Constants.Map.empty : [%t ptyp_constr (Located.lident name) [] ] Elpi.API.Conversion.ctx_entry Elpi.API.RawData.Constants.Map.t) + ] + +let conversion_context_for_tyd (module B : Ast_builder.S) name = let open B in [ + [%stri let [%p pvar @@ elpi_readback_ctx_name name] = { + Elpi.API.Conversion.is_entry_for_nominal = [%e evar @@ elpi_is_ctx_entry_name name ]; + to_key = [%e evar @@ elpi_to_key name ]; + push = [%e evar @@ elpi_push name ]; + pop = [%e evar @@ elpi_pop name ]; + conv = [%e evar name]; + init = (fun state -> Elpi.API.State.set [%e evar @@ elpi_state_name name ] state [%e initial_state (module B) name]); + get = (fun state -> snd @@ Elpi.API.State.get [%e evar @@ elpi_state_name name ] state); + }]] + +let embed_for_tyd (module B : Ast_builder.S) same_mutrec_block all_ctx { name; params; type_decl; index; _ } = let open B in + let is_pred = option_is_some index in match type_decl with - | Opaque -> if params <> [] then error ~loc "opaque data type with parameters not supported"; - value_binding ~pat:(pvar (elpi_embed_name name)) ~expr:[%expr fun ~depth _ _ s t -> [%e evar name].Elpi.API.Conversion.embed ~depth s t ] + | Opaque _ -> if params <> [] then error ~loc "opaque data type with parameters not supported"; + value_binding ~pat:(pvar (elpi_embed_name name)) ~expr:[%expr [%e evar name].Elpi.API.Conversion.embed ] | Alias orig -> - value_binding ~pat:(ppat_constraint (pvar (elpi_embed_name name)) (embed_type (module B) name params is_pred)) + value_binding ~pat:(ppat_constraint (pvar (elpi_embed_name name)) (embed_type (module B) name params is_pred all_ctx)) ~expr:(abstract_expr_over_params (module B) params elpi_embed_name @@ [%expr fun ~depth h c s t -> [%e find_embed_of (module B) same_mutrec_block orig] ~depth h c s t]) | Algebraic(csts,_) -> - value_binding ~pat:(ppat_constraint (pvar (elpi_embed_name name)) (embed_type (module B) name params is_pred)) - ~expr:(abstract_expr_over_params (module B) params elpi_embed_name @@ embed (module B) name (is_pred,ctx) csts) + value_binding ~pat:(ppat_constraint (pvar (elpi_embed_name name)) (embed_type (module B) name params is_pred all_ctx)) + ~expr:(abstract_expr_over_params (module B) params elpi_embed_name @@ embed (module B) is_pred csts) -let readback_for_tyd (module B : Ast_builder.S) (is_pred,ctx) same_mutrec_block { name; params; type_decl; _ } = let open B in +let readback_for_tyd (module B : Ast_builder.S) same_mutrec_block all_ctx { name; params; type_decl; index; _ } = let open B in + let is_pred = option_is_some index in match type_decl with - | Opaque -> if params <> [] then error ~loc "opaque data type with parameters not supported"; - value_binding ~pat:(pvar (elpi_readback_name name)) ~expr:[%expr fun ~depth _ _ s t -> [%e evar name].Elpi.API.Conversion.readback ~depth s t ] + | Opaque _ -> if params <> [] then error ~loc "opaque data type with parameters not supported"; + value_binding ~pat:(pvar (elpi_readback_name name)) ~expr:[%expr [%e evar name].Elpi.API.Conversion.readback ] | Alias orig -> - value_binding ~pat:(ppat_constraint (pvar (elpi_readback_name name)) (readback_type (module B) name params is_pred)) + value_binding ~pat:(ppat_constraint (pvar (elpi_readback_name name)) (readback_type (module B) name params is_pred all_ctx)) ~expr:(abstract_expr_over_params (module B) params elpi_readback_name @@ [%expr fun ~depth h c s t -> [%e find_readback_of (module B) same_mutrec_block orig] ~depth h c s t]) | Algebraic(csts,def_readback) -> - value_binding ~pat:(ppat_constraint (pvar (elpi_readback_name name)) (readback_type (module B) name params is_pred)) - ~expr:(abstract_expr_over_params (module B) params elpi_readback_name @@ readback (module B) name (is_pred,ctx) def_readback csts) + value_binding ~pat:(ppat_constraint (pvar (elpi_readback_name name)) (readback_type (module B) name params is_pred all_ctx)) + ~expr:(abstract_expr_over_params (module B) params elpi_readback_name @@ readback (module B) name is_pred def_readback csts) + +let in_ctx_for_tyd (module B : Ast_builder.S) ctx { name; _ } = let open B in + let ctx = SSet.elements ctx in + [ + pstr_class [class_infos ~virt:Concrete ~params:[] + ~name:(Located.mk @@ elpi_ctx_object_name name) + ~expr:(pcl_fun Nolabel None (ppat_constraint (pvar "h") (ptyp_constr (Located.lident "Elpi.API.Data.hyps") [])) @@ + pcl_fun Nolabel None (ppat_constraint (pvar "s") (ptyp_constr (Located.lident "Elpi.API.Data.state") [])) @@ + pcl_constraint + (pcl_structure @@ class_structure ~self:(pvar "_") + ~fields:( + pcf_inherit Fresh + (pcl_apply (pcl_constr (Located.lident "Elpi.API.Conversion.ctx") []) [Nolabel,evar "h"]) None + :: List.flatten (ctx |> List.map (fun c -> [ + pcf_inherit Override + (pcl_apply (pcl_constr (Located.lident @@ elpi_ctx_object_name c) []) [Nolabel,evar "h";Nolabel,evar "s"]) None ; + pcf_method (Located.mk c,Public,Cfk_concrete (Fresh, + [%expr [%e evar @@ elpi_readback_ctx_name c ].Elpi.API.Conversion.get s]))])))) + (pcty_constr (Located.lident @@ elpi_ctx_class_name name) []))] +; + (* apparently you cannot declare a class type and a class with the same name *) + [%stri let [%p pvar @@ elpi_in_ctx_for_name name ] : + [%t ptyp_constr (Located.lident @@ elpi_ctx_class_name name) []] Elpi.API.Conversion.ctx_readback + = fun ~depth h c s -> [%e + let gls = List.mapi (fun i _ -> Printf.sprintf "gls%d" i) ctx in + let rec aux = function + | [] -> [%expr s, [%e pexp_new @@ Located.lident @@ elpi_ctx_object_name name] h s, List.concat [%e elist @@ List.map evar gls ]] + | (c,gls) :: cs -> + [%expr + let ctx = [%e pexp_new @@ Located.lident @@ elpi_ctx_object_name c] h s in + let s, [%p pvar gls ] = + Elpi.API.PPX.readback_context ~depth [%e evar @@ elpi_readback_ctx_name c] ctx h c s in + [%e aux cs ] + ] + in + aux (List.combine ctx gls) + ]] +] let constants_of_tyd (module B : Ast_builder.S) { type_decl ; elpi_name; name; _ } = let open B in let c_str = elpi_tname_str name in @@ -1012,7 +1273,10 @@ let constants_of_tyd (module B : Ast_builder.S) { type_decl ; elpi_name; name; _ pstr_value Nonrecursive [decl] :: match type_decl with | Alias _ -> [] - | Opaque -> [] + | Opaque opaque_data -> + [pstr_value Nonrecursive [ + value_binding ~pat:(pvar @@ elpi_cdata_name name) + ~expr:[%expr Elpi.API.RawOpaqueData.declare [%e opaque_data]]]] | Algebraic (csts,_) -> List.flatten @@ List.map (fun x -> x.declaration) @@ drop_skip csts let elpi_declaration_of_tyd (module B : Ast_builder.S) tyd = let open B in @@ -1021,25 +1285,25 @@ let elpi_declaration_of_tyd (module B : Ast_builder.S) tyd = let open B in match tyd.type_decl with | Alias orig -> (if tyd.params = [] then (fun x -> x) - else pexp_let Nonrecursive (List.mapi (fun i x -> value_binding ~pat:(pvar x) ~expr:[%expr Elpi.API.ContextualConversion.(!>) @@ Elpi.API.BuiltInData.poly (Printf.sprintf "A%d" [%e eint i]) ]) tyd.params)) + else pexp_let Nonrecursive (List.mapi (fun i x -> value_binding ~pat:(pvar x) ~expr:[%expr Elpi.API.BuiltInData.poly (Printf.sprintf "A%d" [%e eint i]) ]) tyd.params)) [%expr Elpi.API.BuiltIn.LPCode ("typeabbrev " ^ [%e typeabbrev_for (module B) (estring tyd.elpi_name) tyd.params ] ^ " " ^ [%e typeabbrev_for_conv (module B) orig ] ^ ". % " ^ [%e estring tyd.elpi_doc ]) ] - | Opaque -> + | Opaque _ -> [%expr Elpi.API.BuiltIn.MLData [%e if tyd.params = [] then evar tyd.name else error ~loc "opaque with params" ]] | Algebraic _ -> - let vars = List.mapi (fun i _ -> [%expr Elpi.API.ContextualConversion.(!>) @@ Elpi.API.BuiltInData.poly [%e estring @@ Printf.sprintf "A%d" i] ]) tyd.params in - [%expr Elpi.API.BuiltIn.MLDataC [%e + let vars = List.mapi (fun i _ -> [%expr Elpi.API.BuiltInData.poly [%e estring @@ Printf.sprintf "A%d" i] ]) tyd.params in + [%expr Elpi.API.BuiltIn.MLData [%e if tyd.params = [] then evar tyd.name else eapply (evar tyd.name) vars]] in { decl = pstr_value Nonrecursive [value_binding ~pat:(pvar decl_name) ~expr:decl]; decl_name = evar decl_name; } -let mapper_for_tyd (module B : Ast_builder.S) is_pred same_block tyd = let open B in - if is_pred then None else +let mapper_for_tyd (module B : Ast_builder.S) same_block tyd = let open B in + if option_is_some tyd.index then None else let tyvars = List.mapi (fun i _ -> Printf.sprintf "X%d" i) tyd.params in let tyvars1 = List.mapi (fun i _ -> Printf.sprintf "Y%d" i) tyd.params in let ty_w_params vars = @@ -1054,7 +1318,7 @@ let mapper_for_tyd (module B : Ast_builder.S) is_pred same_block tyd = let open estring @@ Printf.sprintf "pred map.%s %s i:%s, o:%s." tyd.elpi_name ty_fvars (ty_w_params tyvars) (ty_w_params tyvars1) in let fvars_str = if fvars = [] then "" else (String.concat " " fvars ^ " ") in match tyd.type_decl with - | Opaque -> None + | Opaque _ -> None | Alias orig -> let mapper = [%expr Printf.sprintf "map.%s %sA B :- %s." @@ -1065,17 +1329,17 @@ let mapper_for_tyd (module B : Ast_builder.S) is_pred same_block tyd = let open | Algebraic(csts,_) -> let mapka ty (v1,v2) = match ty with - | FO { argFO_ty; _ } -> find_mapper_of (module B) same_block param2fv argFO_ty (v1,v2) + | FO { ty; _ } -> find_mapper_of (module B) same_block param2fv ty (v1,v2) | HO _ -> [%expr Printf.sprintf "(pi x\ fixme x => (=) %s %s)" [%e estring @@ v1] [%e estring @@ v2] ] in - let mapk { constant_name; types; _ } = - if types = [] then + let mapk { constant_name; arg_types; _ } = + if arg_types = [] then estring @@ Printf.sprintf "map.%s %s%s %s." tyd.elpi_name fvars_str constant_name constant_name else - let vars = List.mapi (fun i _ -> Printf.sprintf "A%d" i) types in - let vars1 = List.mapi (fun i _ -> Printf.sprintf "B%d" i) types in + let vars = List.mapi (fun i _ -> Printf.sprintf "A%d" i) arg_types in + let vars1 = List.mapi (fun i _ -> Printf.sprintf "B%d" i) arg_types in let vars_s = String.concat " " vars in let vars1_s = String.concat " " vars1 in - let body = List.map2 mapka types (List.combine vars vars1) in + let body = List.map2 mapka arg_types (List.combine vars vars1) in [%expr Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." [%e estring @@ tyd.elpi_name] [%e estring @@ fvars_str] @@ -1086,72 +1350,46 @@ let mapper_for_tyd (module B : Ast_builder.S) is_pred same_block tyd = let open (String.concat ", " [%e elist @@ body])] in let mapper = List.map mapk (drop_skip csts) in Some [%expr String.concat "\n" [%e elist @@ (pred_decl :: mapper @ [estring "\n"])]] +;; -let extras_of_task (module B : Ast_builder.S) (tyd,kind) same_mutrec_block = let open B in - match kind with - | ADT -> { - ty_constants = constants_of_tyd (module B) tyd; - ty_embed = embed_for_tyd (module B) (false,None) same_mutrec_block tyd; - ty_readback = readback_for_tyd (module B) (false,None) same_mutrec_block tyd; - ty_conversion = conversion_for_tyd (module B) false same_mutrec_block tyd; - ty_conversion_name = tyd.name; - ty_context_helpers = []; - ty_context_readback = []; - ty_elpi_declaration = elpi_declaration_of_tyd (module B) tyd; - ty_opaque = tyd.type_decl = Opaque; - ty_library = mapper_for_tyd (module B) false same_mutrec_block tyd; - } - - | HOAS ctx -> { +let extras_of_task (module B : Ast_builder.S) { types; names; context; ctx_names } = let open B in + let is_opaque = function Opaque _ -> true | _ -> false in + let ty_extras = + types |> List.map (fun tyd -> { ty_constants = constants_of_tyd (module B) tyd; - ty_embed = embed_for_tyd (module B) (false,Some ctx) same_mutrec_block tyd; - ty_readback = readback_for_tyd (module B) (false,Some ctx) same_mutrec_block tyd; - - ty_conversion = conversion_for_tyd (module B) false same_mutrec_block tyd; + ty_embed = embed_for_tyd (module B) names ctx_names tyd; + ty_readback = readback_for_tyd (module B) names ctx_names tyd; + ty_ctx_class_type = ctx_class_type_for_tyd (module B) ctx_names tyd; + ty_conversion = conversion_for_tyd (module B) ctx_names tyd; ty_conversion_name = tyd.name; - ty_context_helpers = []; - ty_context_readback = []; ty_elpi_declaration = elpi_declaration_of_tyd (module B) tyd; - ty_opaque = tyd.type_decl = Opaque; - ty_library = mapper_for_tyd (module B) false same_mutrec_block tyd; - } - - | CTX (m,deps) -> - let name = tyd.name in - let elpi_Map = elpi_Map ~loc name in + ty_opaque = is_opaque tyd.type_decl; + ty_library = mapper_for_tyd (module B) names tyd; + ty_in_ctx = in_ctx_for_tyd (module B) ctx_names tyd; + }) in + let ctx_extras = + match context with + | None -> None + | Some(name,m,tyd) -> let elpi_name = tyd.elpi_name in - let csts = match tyd.type_decl with Algebraic(x,_) -> x | _ -> error "context ADT must be explicit" in - { - ty_constants = constants_of_tyd (module B) tyd; - ty_embed = embed_for_tyd (module B) (true,None) same_mutrec_block tyd; - ty_readback = readback_for_tyd (module B) (true,None) same_mutrec_block tyd; - ty_conversion = conversion_for_tyd (module B) true same_mutrec_block tyd; - ty_conversion_name = tyd.name; + let csts = + match tyd.type_decl with Algebraic(x,_) -> x | _ -> error "context ADT must be explicit" in + Some { ty_context_helpers = [ pstr_module (module_binding ~name:(Located.mk (elpi_map_name name)) ~expr:(pmod_apply (pmod_ident (Located.mk (Longident.parse "Elpi.API.Utils.Map.Make"))) m)); pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_state_name name)) ~expr:[%expr Elpi.API.State.declare ~name:[%e estring elpi_name] ~pp:(fun fmt _ -> Format.fprintf fmt "TODO") - ~init:(fun () -> - ([%e elpi_Map "empty" ] : - [%t ptyp_constr (Located.lident (elpi_map_name name ^ ".t")) [ [%type: Elpi.API.RawData.constant] ] ]), - (Elpi.API.RawData.Constants.Map.empty : [%t ptyp_constr (Located.lident name) [] ] Elpi.API.ContextualConversion.ctx_entry Elpi.API.RawData.Constants.Map.t)) + ~init:(fun () -> [%e initial_state (module B) name]); ]]; pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_to_key name)) ~expr:(ctx_entry_key (module B) csts)]; pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_is_ctx_entry_name name)) ~expr:(is_ctx_entry (module B) csts)]; pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_push name)) ~expr:(ctx_push (module B) name)]; pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_pop name)) ~expr:(ctx_pop (module B) name)]; ]; - ty_context_readback = [ - pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_in_name_alone name)) ~expr:(ctx_readback (module B) name)]; - pstr_value Nonrecursive [value_binding ~pat:(pvar (elpi_in_name name)) ~expr:( - compose_ctx_readback (module B) (deps @ [name]) - )] - ]; - ty_elpi_declaration = elpi_declaration_of_tyd (module B) tyd; - ty_opaque = tyd.type_decl = Opaque; - ty_library = mapper_for_tyd (module B) true same_mutrec_block tyd; - } + ty_context_readback = conversion_context_for_tyd (module B) tyd.name; + } in + { ty_extras; ctx_extras } ;; let analyze_typedecl (module B : Ast_builder.S) same_mutrec_block tdecl = @@ -1159,21 +1397,23 @@ let analyze_typedecl (module B : Ast_builder.S) same_mutrec_block tdecl = | { ptype_name = { txt = name ; _ }; ptype_params = params; - ptype_cstrs = []; - ptype_kind = Ptype_abstract; + ptype_cstrs = _; + ptype_kind = k; ptype_manifest = None; _ - } -> + } when k = Ptype_abstract || has_elpi_tcdata tdecl -> let params, _ = analyze_params (module B) params in let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in let elpi_doc = get_elpi_tdoc name tdecl in let pp = get_elpi_pp tdecl in - { name; params; type_decl = Opaque; elpi_name; elpi_code; elpi_doc; pp } + let index = get_elpi_tindex tdecl in + let cdata = get_elpi_tcdata ~loc:B.loc tdecl in + { name; params; type_decl = Opaque cdata; elpi_name; elpi_code; elpi_doc; pp; index } | { ptype_name = { txt = name ; _ }; ptype_params = params; - ptype_cstrs = []; + ptype_cstrs = _; ptype_kind = Ptype_abstract; ptype_manifest = Some alias; _ @@ -1183,12 +1423,13 @@ let analyze_typedecl (module B : Ast_builder.S) same_mutrec_block tdecl = let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in let elpi_doc = get_elpi_tdoc name tdecl in let pp = get_elpi_pp tdecl in - { name; params; type_decl = Alias alias; elpi_name; elpi_code; elpi_doc; pp } + let index = get_elpi_tindex tdecl in + { name; params; type_decl = Alias alias; elpi_name; elpi_code; elpi_doc; pp; index } | { ptype_name = { txt = name ; _ }; ptype_params = params; - ptype_cstrs = []; + ptype_cstrs = _; ptype_kind = Ptype_variant csts; _ } -> @@ -1197,14 +1438,15 @@ let analyze_typedecl (module B : Ast_builder.S) same_mutrec_block tdecl = let csts = List.map (analyze_constructor (module B) name same_mutrec_block) csts in let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in let elpi_doc = get_elpi_tdoc name tdecl in - let default_readback = get_elpi_treadback tdecl in + let default_readback = get_elpi_tdefkreadback tdecl in let pp = get_elpi_pp tdecl in - { name; params; type_decl = Algebraic(csts,default_readback); elpi_name; elpi_code; elpi_doc; pp } + let index = get_elpi_tindex tdecl in + { name; params; type_decl = Algebraic(csts,default_readback); elpi_name; elpi_code; elpi_doc; pp; index } | { ptype_name = { txt = name ; _ }; ptype_params = params; - ptype_cstrs = []; + ptype_cstrs = _; ptype_kind = Ptype_record lbltl; ptype_attributes; _ @@ -1224,16 +1466,44 @@ let analyze_typedecl (module B : Ast_builder.S) same_mutrec_block tdecl = let csts = [analyze_tuple_constructor (module B) name name kdecl tl make_k match_k same_mutrec_block] in let elpi_name, elpi_code = get_elpi_tcode (module B) name tdecl in let elpi_doc = get_elpi_tdoc name tdecl in - let default_readback = get_elpi_treadback tdecl in + let default_readback = get_elpi_tdefkreadback tdecl in let pp = get_elpi_pp tdecl in - { name; params; type_decl = Algebraic(csts,default_readback); elpi_name; elpi_code; elpi_doc; pp } + let index = get_elpi_tindex tdecl in + { name; params; type_decl = Algebraic(csts,default_readback); elpi_name; elpi_code; elpi_doc; pp; index } | _ -> error ~loc:B.loc "unsupportd type declaration" ;; -let typedecl_extras index context (module B : Ast_builder.S) tyd_names tyd = - let open B in - let tyd = analyze_typedecl (module B) tyd_names tyd in +let typedecl_extras (module B : Ast_builder.S) all_context tyds = + let tyd_names = List.map (fun x -> x.ptype_name.txt) tyds in + let tyds = List.map (analyze_typedecl (module B) tyd_names) tyds in + let ctx_names = + List.fold_left (fun acc x -> match x.type_decl with + | Opaque _ | Alias _ -> acc + | Algebraic (cl,_) -> + List.fold_left (fun acc -> function + | Skip _ -> acc + | Expose { ctx_names; _ } -> List.fold_right SSet.add ctx_names acc) + acc cl) + SSet.empty tyds in + let ctx_names = + match all_context with + | None -> ctx_names + | Some all -> + let all = parse_lident_list (module B) all in + let all = SSet.of_list all in + if not (SSet.subset ctx_names all) then + error ~loc:B.loc "[deriving elpi { context }] directive contains %a but the type mentions more: %a" SSet.pp all SSet.pp (SSet.diff ctx_names all); + all in + + let context = consistency_check ~loc:B.loc tyds in + + let mut = { types = tyds; ctx_names; names = tyd_names; context } in + + extras_of_task (module B) mut +;; + +(* let one_ty t = match t.ptyp_desc with | Ptyp_constr({ txt; _ },args) -> @@ -1241,7 +1511,7 @@ let typedecl_extras index context (module B : Ast_builder.S) tyd_names tyd = else if List.length (Longident.flatten_exn txt) > 1 then nYI ~loc ~__LOC__ () else String.concat "." (Longident.flatten_exn txt) - | _ -> error ~loc "[elpi.context] payload is invalid: %a" Ocaml_common.Pprintast.core_type (Selected_ast.To_ocaml.copy_core_type t) in + | _ -> error ~loc "[@elpi.context] payload is invalid: %a" Ocaml_common.Pprintast.core_type (Selected_ast.To_ocaml.copy_core_type t) in let one_arrow t = match t.ptyp_desc with | Ptyp_arrow(_,s,t) -> one_ty s , one_ty t @@ -1257,26 +1527,29 @@ let typedecl_extras index context (module B : Ast_builder.S) tyd_names tyd = | Ptyp_arrow _ -> HOAS [one_arrow ty] | _ -> HOAS [tyd.name, one_ty ty] in + let task = tyd, kind in consistency_check ~loc:B.loc task; extras_of_task (module B) task tyd_names ;; +*) -let tydecls ~loc index context append _r tdls = +let tydecls ~loc append_decl append_mapper all_context _r tdls = let module B = Ast_builder.Make(struct let loc = loc end) in let open B in - let extra = List.map (typedecl_extras index context (module B) (List.map (fun x -> x.ptype_name.txt) tdls)) tdls in - let opaque_extra, non_opaque_extra = List.partition (fun x -> x.ty_opaque) extra in + let { ty_extras; ctx_extras } = typedecl_extras (module B) all_context tdls in + let opaque_extra, non_opaque_extra = List.partition (fun x -> x.ty_opaque) ty_extras in pstr_attribute { attr_name = Located.mk "warning"; attr_payload = PStr [pstr_eval (estring "-26-27-32-39-60") []]; attr_loc = loc } :: - List.(concat (map (fun x -> x.ty_constants) extra)) @ - List.(concat (map (fun x -> x.ty_context_helpers) extra)) @ + List.(concat (map (fun x -> x.ty_constants) ty_extras)) @ + option_default [] (option_map (fun x -> x.ty_context_helpers) ctx_extras) @ + List.(map (fun x -> x.ty_ctx_class_type) ty_extras) @ begin if opaque_extra <> [] then - List.(map (fun x -> pstr_value Nonrecursive [x.ty_conversion]) opaque_extra) @ + List.(map (fun x -> x.ty_conversion) opaque_extra) @ [pstr_value Nonrecursive List.(map (fun x -> x.ty_embed) opaque_extra)] @ [pstr_value Nonrecursive List.(map (fun x -> x.ty_readback) opaque_extra)] else [] end @ @@ -1284,22 +1557,30 @@ let tydecls ~loc index context append _r tdls = begin if non_opaque_extra <> [] then [pstr_value Recursive List.(map (fun x -> x.ty_embed) non_opaque_extra)] @ [pstr_value Recursive List.(map (fun x -> x.ty_readback) non_opaque_extra)] @ - List.(map (fun x -> pstr_value Nonrecursive [x.ty_conversion]) non_opaque_extra) + List.(map (fun x -> x.ty_conversion) non_opaque_extra) else [] end @ - List.(concat (map (fun x -> x.ty_context_readback) extra)) @ - List.(map (fun x -> x.ty_elpi_declaration.decl) extra) @ - match append with + option_default [] (option_map (fun x -> x.ty_context_readback) ctx_extras) @ + List.(map (fun x -> x.ty_elpi_declaration.decl) ty_extras) @ + List.(concat (map (fun x -> x.ty_in_ctx) ty_extras)) @ + + begin match append_decl with | None -> [] | Some l -> [pstr_value Nonrecursive [value_binding ~pat:(punit) ~expr:[%expr [%e l] := ![%e l] @ - [%e elist @@ List.(map (fun x -> x.ty_elpi_declaration.decl_name) extra) ] - @ - [%e elist @@ List.concat (List.map (fun x -> + [%e elist @@ List.(map (fun x -> x.ty_elpi_declaration.decl_name) ty_extras) ]]]] + end @ + + begin match append_mapper with + | None -> [] + | Some l -> [pstr_value Nonrecursive [value_binding ~pat:(punit) + ~expr:[%expr [%e l] := ![%e l] @ [String.concat "\n" + [%e elist @@ List.map (fun x -> match x.ty_library with - | None -> [] - | Some e -> [[%expr Elpi.API.BuiltIn.LPCode [%e e]]]) extra)] - ]]] + | None -> [%expr ""] + | Some e -> e) ty_extras] + ]]]] + end ;; let conversion_of_expansion ~loc ~path:_ ty = @@ -1312,8 +1593,8 @@ let conversion_extension = Ast_pattern.(ptyp __) conversion_of_expansion -let expand_str ~loc ~path:_ (r,tydecl) (index : module_expr option) (context : core_type option) (append : expression option) = tydecls ~loc index context append r tydecl -let expand_sig ~loc ~path:_ (_r,_tydecl) (_index : module_expr option) (_context : core_type option) = nYI ~loc ~__LOC__ () +let expand_str ~loc ~path:_ (r,tydecl) (declaration : expression option) (mapper : expression option) (context : expression option) = tydecls ~loc declaration mapper context r tydecl +let expand_sig ~loc ~path:_ (_r,_tydecl) (_index : module_expr option) = nYI ~loc ~__LOC__ () let attributes = Attribute.([ T att_elpi_tcode; @@ -1335,11 +1616,8 @@ let str_type_decl_generator = arguments expand_str -let pexp_ignore = Deriving.Args.of_func (fun _ _ (_e : expression) b -> b) - let arguments = Deriving.Args.(empty +> arg "index" (pexp_pack __) - +> arg "context" (pexp_constraint pexp_ignore __) ) let sig_type_decl_generator = diff --git a/ppx_elpi/tests/dune b/ppx_elpi/tests/dune index 3f3fa4343..05663311d 100644 --- a/ppx_elpi/tests/dune +++ b/ppx_elpi/tests/dune @@ -5,6 +5,7 @@ (executable (name pp) (modules pp) + (promote) (libraries elpi.ppx ppxlib)) (include dune.inc) diff --git a/ppx_elpi/tests/dune.inc b/ppx_elpi/tests/dune.inc index a7e9e99e4..2d576f448 100644 --- a/ppx_elpi/tests/dune.inc +++ b/ppx_elpi/tests/dune.inc @@ -68,6 +68,29 @@ (preprocess (pps elpi.ppx))) +(rule + (targets test_mutual_contextual.actual.ml) + (deps (:pp pp.exe) (:input test_mutual_contextual.ml)) + (action (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_mutual_contextual.expected.ml test_mutual_contextual.actual.ml))) + +(rule + (alias runtest) + (action (diff test_mutual_contextual.expected.elpi test_mutual_contextual.actual.elpi))) + +(rule + (target test_mutual_contextual.actual.elpi) + (action (run ./test_mutual_contextual.exe %{target}))) + +(executable + (name test_mutual_contextual) + (modules test_mutual_contextual) + (preprocess (pps elpi.ppx))) + + (rule (targets test_opaque_type.actual.ml) (deps (:pp pp.exe) (:input test_opaque_type.ml)) diff --git a/ppx_elpi/tests/test_alias_type.expected.elpi b/ppx_elpi/tests/test_alias_type.expected.elpi index 0d28b71bd..9a92e117a 100644 --- a/ppx_elpi/tests/test_alias_type.expected.elpi +++ b/ppx_elpi/tests/test_alias_type.expected.elpi @@ -2,9 +2,6 @@ typeabbrev simple int. % simple -pred map.simple i:simple, o:simple. -map.simple A B :- ((=) A B). - diff --git a/ppx_elpi/tests/test_alias_type.expected.ml b/ppx_elpi/tests/test_alias_type.expected.ml index 448c2d3a3..f76131bb9 100644 --- a/ppx_elpi/tests/test_alias_type.expected.ml +++ b/ppx_elpi/tests/test_alias_type.expected.ml @@ -1,6 +1,6 @@ let elpi_stuff = ref [] let pp_simple _ _ = () -type simple = int[@@deriving elpi { append = elpi_stuff }] +type simple = int[@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -8,30 +8,23 @@ include let elpi_constant_type_simplec = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_simple + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.embedding = fun ~depth -> fun h -> fun c -> fun s -> fun t -> Elpi.API.PPX.embed_int ~depth h c s t let rec elpi_readback_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.readback = fun ~depth -> fun h -> fun c -> fun s -> fun t -> Elpi.API.PPX.readback_int ~depth h c s t - let simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t + let simple : 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "simple" in + let kind = Elpi.API.Conversion.TyName "simple" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; ()); @@ -45,18 +38,17 @@ include ("simple" ^ (" " ^ (((Elpi.API.PPX.Doc.show_ty_ast ~outer:false) @@ - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty) + Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty) ^ (". % " ^ "simple"))))) - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:simple, o:simple."; - Printf.sprintf "map.%s %sA B :- %s." "simple" "" - ("(" ^ ("(=)" ^ (" " ^ ("A" ^ (" " ^ ("B" ^ ")"))))))])])) + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API let builtin = diff --git a/ppx_elpi/tests/test_alias_type.ml b/ppx_elpi/tests/test_alias_type.ml index 7b1ab6236..6c9b075f0 100644 --- a/ppx_elpi/tests/test_alias_type.ml +++ b/ppx_elpi/tests/test_alias_type.ml @@ -2,7 +2,7 @@ let elpi_stuff = ref [] let pp_simple _ _ = () type simple = int -[@@deriving elpi { append = elpi_stuff }] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API @@ -15,4 +15,4 @@ let main () = exit 0 ;; -main () \ No newline at end of file +main () diff --git a/ppx_elpi/tests/test_double_contextual.expected.elpi b/ppx_elpi/tests/test_double_contextual.expected.elpi index b0954e994..f7a8480f3 100644 --- a/ppx_elpi/tests/test_double_contextual.expected.elpi +++ b/ppx_elpi/tests/test_double_contextual.expected.elpi @@ -1,7 +1,7 @@ -% tctx -kind tctx type. +% tyctx +kind tyctx type. type tentry nominal -> string -> bool -> prop. % TEntry % ty @@ -9,15 +9,8 @@ kind ty type. type tapp string -> ty -> ty. % TApp type tall bool -> string -> (ty -> ty) -> ty. % TAll -pred map.ty i:ty, o:ty. -map.ty (tvar A0) (tvar B0) :- ((=) A0 B0). -map.ty (tapp A0 A1) (tapp B0 B1) :- ((=) A0 B0), (map.ty A1 B1). -map.ty (tall A0 A1 A2) (tall B0 B1 B2) :- ((=) A0 B0), ((=) A1 B1), (pi x fixme x => (=) A2 B2). - - - -% ctx -kind ctx type. +% tctx +kind tctx type. type entry nominal -> string -> ty -> prop. % Entry % term @@ -25,13 +18,6 @@ kind term type. type app term -> term -> term. % App type lam ty -> string -> (term -> term) -> term. % Lam -pred map.term i:term, o:term. -map.term (var A0) (var B0) :- ((=) A0 B0). -map.term (app A0 A1) (app B0 B1) :- (map.term A0 B0), (map.term A1 B1). -map.term (lam A0 A1 A2) (lam B0 B1 B2) :- ((=) A0 B0), ((=) A1 B1), (pi x fixme x => (=) A2 B2). - - - diff --git a/ppx_elpi/tests/test_double_contextual.expected.ml b/ppx_elpi/tests/test_double_contextual.expected.ml index 3e2b3dac4..89496e754 100644 --- a/ppx_elpi/tests/test_double_contextual.expected.ml +++ b/ppx_elpi/tests/test_double_contextual.expected.ml @@ -1,46 +1,43 @@ -let elpi_stuff = ref [] +let declaration = ref [] module String = struct include String let pp fmt s = Format.fprintf fmt "%s" s let show = Format.asprintf "%a" pp end -let pp_tctx _ _ = () -type tctx = - | TEntry of ((string)[@elpi.key ]) * bool [@@deriving - elpi - { - append = elpi_stuff; - index = (module String) - }] +let pp_tyctx _ _ = () +type tyctx = + | TEntry of ((string)[@elpi.key ]) * bool [@@elpi.index (module String)] +[@@deriving elpi { declaration }] include struct [@@@warning "-26-27-32-39-60"] - let elpi_constant_type_tctx = "tctx" - let elpi_constant_type_tctxc = + let elpi_constant_type_tyctx = "tyctx" + let elpi_constant_type_tyctxc = Elpi.API.RawData.Constants.declare_global_symbol - elpi_constant_type_tctx - let elpi_constant_constructor_tctx_TEntry = "tentry" - let elpi_constant_constructor_tctx_TEntryc = + elpi_constant_type_tyctx + let elpi_constant_constructor_tyctx_TEntry = "tentry" + let elpi_constant_constructor_tyctx_TEntryc = Elpi.API.RawData.Constants.declare_global_symbol - elpi_constant_constructor_tctx_TEntry - module Elpi_tctx_Map = (Elpi.API.Utils.Map.Make)(String) - let elpi_tctx_state = - Elpi.API.State.declare ~name:"tctx" + elpi_constant_constructor_tyctx_TEntry + module Elpi_tyctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_tyctx_state = + Elpi.API.State.declare ~name:"tyctx" ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") ~init:(fun () -> - ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant - Elpi_tctx_Map.t), - (Elpi.API.RawData.Constants.Map.empty : tctx - Elpi.API.ContextualConversion.ctx_entry + ((Elpi_tyctx_Map.empty : Elpi.API.RawData.constant + Elpi_tyctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tyctx + Elpi.API.Conversion.ctx_entry Elpi.API.RawData.Constants.Map.t))) - let elpi_tctx_to_key ~depth:_ = - function | TEntry (elpi__1, _) -> elpi__1 - let elpi_is_tctx ~depth:elpi__depth elpi__x = + let elpi_tyctx_to_key ~depth:_ = + function | TEntry (elpi__16, _) -> elpi__16 + let elpi_is_tyctx { Elpi.API.Data.hdepth = elpi__depth; hsrc = elpi__x } + = match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const _ -> None | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> - if false || (elpi__hd == elpi_constant_constructor_tctx_TEntryc) + if false || (elpi__hd == elpi_constant_constructor_tyctx_TEntryc) then (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with | Elpi.API.RawData.Const x -> Some x @@ -49,59 +46,62 @@ include "context entry applied to a non nominal") else None | _ -> None - let elpi_push_tctx ~depth:elpi__depth elpi__state elpi__name + let elpi_push_tyctx ~depth:elpi__depth elpi__state elpi__name elpi__ctx_item = let (elpi__ctx2dbl, elpi__dbl2ctx) = - Elpi.API.State.get elpi_tctx_state elpi__state in + Elpi.API.State.get elpi_tyctx_state elpi__state in let elpi__i = elpi__depth in - let elpi__ctx2dbl = Elpi_tctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__ctx2dbl = Elpi_tyctx_Map.add elpi__name elpi__i elpi__ctx2dbl in let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item elpi__dbl2ctx in let elpi__state = - Elpi.API.State.set elpi_tctx_state elpi__state + Elpi.API.State.set elpi_tyctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state - let elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__name = + let elpi_pop_tyctx ~depth:elpi__depth elpi__state elpi__name = let (elpi__ctx2dbl, elpi__dbl2ctx) = - Elpi.API.State.get elpi_tctx_state elpi__state in + Elpi.API.State.get elpi_tyctx_state elpi__state in let elpi__i = elpi__depth in - let elpi__ctx2dbl = Elpi_tctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__ctx2dbl = Elpi_tyctx_Map.remove elpi__name elpi__ctx2dbl in let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in let elpi__state = - Elpi.API.State.set elpi_tctx_state elpi__state + Elpi.API.State.set elpi_tyctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state - let rec elpi_embed_tctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + module Ctx_for_tyctx = + struct class type t = object inherit Elpi.API.Conversion.ctx end end + let rec elpi_embed_tyctx : + 'c . + ((Elpi.API.RawData.constant * tyctx), #Ctx_for_tyctx.t as 'c) + Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> fun elpi__state -> function - | (elpi__10, TEntry (elpi__8, elpi__9)) -> + | (elpi__9, TEntry (elpi__7, elpi__8)) -> + let (elpi__state, elpi__13, elpi__10) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__9 in let (elpi__state, elpi__14, elpi__11) = - Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__10 in - let (elpi__state, elpi__15, elpi__12) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__8 in - let (elpi__state, elpi__16, elpi__13) = + elpi__constraints elpi__state elpi__7 in + let (elpi__state, elpi__15, elpi__12) = Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__9 in + elpi__constraints elpi__state elpi__8 in (elpi__state, (Elpi.API.RawData.mkAppL - elpi_constant_constructor_tctx_TEntryc - [elpi__14; elpi__15; elpi__16]), - (List.concat [elpi__11; elpi__12; elpi__13])) - let rec elpi_readback_tctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + elpi_constant_constructor_tyctx_TEntryc + [elpi__13; elpi__14; elpi__15]), + (List.concat [elpi__10; elpi__11; elpi__12])) + let rec elpi_readback_tyctx : + 'c . + ((Elpi.API.RawData.constant * tyctx), #Ctx_for_tyctx.t as 'c) + Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> @@ -110,121 +110,92 @@ include fun elpi__x -> match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when - elpi__hd == elpi_constant_constructor_tctx_TEntryc -> - let (elpi__state, elpi__7, elpi__6) = - Elpi.API.PPX.readback_nominal ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__x in + elpi__hd == elpi_constant_constructor_tyctx_TEntryc -> + let (elpi__state, elpi__6, elpi__5) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in (match elpi__xs with - | elpi__2::elpi__3::[] -> - let (elpi__state, elpi__2, elpi__4) = + | elpi__1::elpi__2::[] -> + let (elpi__state, elpi__1, elpi__3) = Elpi.API.PPX.readback_string ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__2 in - let (elpi__state, elpi__3, elpi__5) = + elpi__hyps elpi__constraints elpi__state elpi__1 in + let (elpi__state, elpi__2, elpi__4) = Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__3 in + elpi__hyps elpi__constraints elpi__state elpi__2 in (elpi__state, - (elpi__7, (TEntry (elpi__2, elpi__3))), - (List.concat [elpi__6; elpi__4; elpi__5])) + (elpi__6, (TEntry (elpi__1, elpi__2))), + (List.concat [elpi__5; elpi__3; elpi__4])) | _ -> Elpi.API.Utils.type_error ("Not enough arguments to constructor: " ^ (Elpi.API.RawData.Constants.show - elpi_constant_constructor_tctx_TEntryc))) + elpi_constant_constructor_tyctx_TEntryc))) | _ -> Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" - "tctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let tctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + "tyctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let tyctx : + 'c . + ((Elpi.API.RawData.constant * tyctx), #Ctx_for_tyctx.t as 'c) + Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "tctx" in + let kind = Elpi.API.Conversion.TyName "tyctx" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> - Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tyctx"; Elpi.API.PPX.Doc.constructor fmt - ~ty:(Elpi.API.ContextualConversion.TyName "prop") - ~name:"tentry" ~doc:"TEntry" - ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); - pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); - embed = elpi_embed_tctx; - readback = elpi_readback_tctx + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"tentry" + ~doc:"TEntry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_tyctx fmt x); + embed = elpi_embed_tyctx; + readback = elpi_readback_tyctx } - let in_tctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state = - let module CMap = Elpi.API.RawData.Constants.Map in - let elpi__filtered_hyps = - List.fold_left - (fun elpi__m -> - fun - ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as - elpi__hyp) - -> - match elpi_is_tctx ~depth:elpi__i elpi__hsrc with - | None -> elpi__m - | Some elpi__idx -> - (if CMap.mem elpi__idx elpi__m - then - Elpi.API.Utils.type_error - "more than one context entry for the same nominal"; - CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty - (Elpi.API.RawData.of_hyps elpi__hyps) in - let rec elpi__aux elpi__state elpi__gls elpi__i = - if elpi__i = elpi__depth - then (elpi__state, (List.concat (List.rev elpi__gls))) - else - if not (CMap.mem elpi__i elpi__filtered_hyps) - then elpi__aux elpi__state elpi__gls (elpi__i + 1) - else - (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in - let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in - let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = - tctx.Elpi.API.ContextualConversion.readback - ~depth:elpi__hyp_depth elpi__hyps elpi__constraints - elpi__state elpi__hyp.Elpi.API.RawData.hsrc in - assert (elpi__nominal = elpi__i); - (let elpi__s = elpi_tctx_to_key ~depth:elpi__hyp_depth elpi__t in - let elpi__state = - elpi_push_tctx ~depth:elpi__i elpi__state elpi__s - { - Elpi.API.ContextualConversion.entry = elpi__t; - depth = elpi__hyp_depth - } in - elpi__aux elpi__state (elpi__gls_t :: elpi__gls) - (elpi__i + 1))) in - let elpi__state = - Elpi.API.State.set elpi_tctx_state elpi__state - (Elpi_tctx_Map.empty, CMap.empty) in - let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in - let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_tctx_state elpi__state in - (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) - let in_tctx = in_tctx_alone - let elpi_tctx = Elpi.API.BuiltIn.MLDataC tctx - let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_tctx] @ [])) + let context_made_of_tyctx = + { + Elpi.API.Conversion.is_entry_for_nominal = elpi_is_tyctx; + to_key = elpi_tyctx_to_key; + push = elpi_push_tyctx; + pop = elpi_pop_tyctx; + conv = tyctx; + init = + (fun state -> + Elpi.API.State.set elpi_tyctx_state state + ((Elpi_tyctx_Map.empty : Elpi.API.RawData.constant + Elpi_tyctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tyctx + Elpi.API.Conversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))); + get = + (fun state -> snd @@ (Elpi.API.State.get elpi_tyctx_state state)) + } + let elpi_tyctx = Elpi.API.BuiltIn.MLData tyctx + class ctx_for_tyctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tyctx.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_tyctx : Ctx_for_tyctx.t Elpi.API.Conversion.ctx_readback) + = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_tyctx) h s), (List.concat [])) + let () = declaration := ((!declaration) @ [elpi_tyctx]) end[@@ocaml.doc "@inline"][@@merlin.hide ] let pp_ty _ _ = () type ty = - | TVar of string [@elpi.var ] + | TVar of string [@elpi.var tyctx] | TApp of string * ty | TAll of bool * string * - ((ty)[@elpi.binder fun b -> fun s -> TEntry (s, b)]) [@@deriving - elpi - { - append = - elpi_stuff; - context = - (() : - ty -> - tctx) - }] + ((ty)[@elpi.binder tyctx (fun b -> fun s -> TEntry (s, b))]) [@@deriving + elpi + { + declaration + }] include struct [@@@warning "-26-27-32-39-60"] @@ -243,11 +214,17 @@ include let elpi_constant_constructor_ty_TAllc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_ty_TAll + module Ctx_for_ty = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tyctx.t + method tyctx : tyctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_ty : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -255,13 +232,13 @@ include function | TVar elpi__29 -> let (elpi__ctx2dbl, _) = - Elpi.API.State.get elpi_tctx_state elpi__state in + Elpi.API.State.get elpi_tyctx_state elpi__state in let elpi__key = (fun x -> x) elpi__29 in - (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) + (if not (Elpi_tyctx_Map.mem elpi__key elpi__ctx2dbl) then Elpi.API.Utils.error "Unbound variable"; (elpi__state, (Elpi.API.RawData.mkBound - (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) + (Elpi_tyctx_Map.find elpi__key elpi__ctx2dbl)), [])) | TApp (elpi__32, elpi__33) -> let (elpi__state, elpi__36, elpi__34) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps @@ -284,21 +261,21 @@ include let elpi__ctx_entry = (fun b -> fun s -> TEntry (s, b)) elpi__38 elpi__39 in let elpi__ctx_key = - elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + elpi_tyctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = - elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state + elpi_push_tyctx ~depth:(elpi__depth + 1) elpi__state elpi__ctx_key elpi__ctx_entry in let (elpi__state, elpi__47, elpi__43) = elpi_embed_ty ~depth:(elpi__depth + 1) elpi__hyps elpi__constraints elpi__state elpi__40 in let elpi__46 = Elpi.API.RawData.mkLam elpi__47 in let elpi__state = - elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state + elpi_pop_tyctx ~depth:(elpi__depth + 1) elpi__state elpi__ctx_key in (elpi__state, (Elpi.API.RawData.mkAppL @@ -306,10 +283,7 @@ include [elpi__44; elpi__45; elpi__46]), (List.concat [elpi__41; elpi__42; elpi__43])) let rec elpi_readback_ty : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -318,7 +292,7 @@ include match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_tctx_state elpi__state in + Elpi.API.State.get elpi_tyctx_state elpi__state in (if not (Elpi.API.RawData.Constants.Map.mem elpi__hd @@ -328,17 +302,16 @@ include (Format.asprintf "Unbound variable: %s in %a" (Elpi.API.RawData.Constants.show elpi__hd) (Elpi.API.RawData.Constants.Map.pp - (Elpi.API.ContextualConversion.pp_ctx_entry - pp_tctx)) elpi__dbl2ctx); - (let { - Elpi.API.ContextualConversion.entry = elpi__entry; + (Elpi.API.Conversion.pp_ctx_entry pp_tyctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd elpi__dbl2ctx in (elpi__state, (TVar - (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), + (elpi_tyctx_to_key ~depth:elpi__depth elpi__entry)), []))) | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_ty_TAppc -> @@ -372,16 +345,15 @@ include (fun b -> fun s -> TEntry (s, b)) elpi__28 elpi__23 in let elpi__ctx_key = - elpi_tctx_to_key ~depth:elpi__depth + elpi_tyctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = - elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = - elpi_push_tctx ~depth:elpi__depth elpi__state + elpi_push_tyctx ~depth:elpi__depth elpi__state elpi__ctx_key elpi__ctx_entry in let (elpi__state, elpi__24, elpi__26) = match Elpi.API.RawData.look ~depth:elpi__depth @@ -393,7 +365,7 @@ include elpi__bo | _ -> assert false in let elpi__state = - elpi_pop_tctx ~depth:elpi__depth elpi__state + elpi_pop_tyctx ~depth:elpi__depth elpi__state elpi__ctx_key in (elpi__state, (TAll (elpi__28, elpi__23, elpi__24)), (List.concat [elpi__27; elpi__25; elpi__26])) @@ -406,105 +378,81 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "ty" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let ty : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "ty" in + let ty : 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "ty" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"ty"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tapp" ~doc:"TApp" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyName - elpi_constant_type_ty]; + ~args:[Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyName elpi_constant_type_ty]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tall" ~doc:"TAll" - ~args:[(Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyApp - ("->", (Elpi.API.ContextualConversion.TyName "ty"), - [Elpi.API.ContextualConversion.TyName - elpi_constant_type_ty])]); + ~args:[Elpi.Builtin.bool.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "ty"), + [Elpi.API.Conversion.TyName elpi_constant_type_ty])]); pp = pp_ty; embed = elpi_embed_ty; readback = elpi_readback_ty } - let elpi_ty = Elpi.API.BuiltIn.MLDataC ty - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_ty] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.ty i:ty, o:ty."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "ty" "" - "tvar" "A0" "tvar" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "ty" "" - "tapp" "A0 A1" "tapp" "B0 B1" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - (("map." ^ elpi_constant_type_ty) ^ - (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "ty" "" - "tall" "A0 A1 A2" "tall" "B0 B1 B2" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")"))))); - Printf.sprintf "(pi x fixme x => (=) %s %s)" "A2" - "B2"]); - "\n"])])) + let elpi_ty = Elpi.API.BuiltIn.MLData ty + class ctx_for_ty (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_ty.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tyctx) h s) + method tyctx = context_made_of_tyctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_ty : Ctx_for_ty.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tyctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tyctx + ctx h c s in + (s, ((new ctx_for_ty) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_ty]) end[@@ocaml.doc "@inline"][@@merlin.hide ] -let pp_ctx _ _ = () -type ctx = - | Entry of ((string)[@elpi.key ]) * ty [@@deriving - elpi - { - append = elpi_stuff; - index = (module String); - context = (() : tctx) - }] +let pp_tctx _ _ = () +type tctx = + | Entry of ((string)[@elpi.key ]) * ty [@@elpi.index (module String)] +[@@deriving elpi { declaration; context = [tyctx] }] include struct [@@@warning "-26-27-32-39-60"] - let elpi_constant_type_ctx = "ctx" - let elpi_constant_type_ctxc = - Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ctx - let elpi_constant_constructor_ctx_Entry = "entry" - let elpi_constant_constructor_ctx_Entryc = + let elpi_constant_type_tctx = "tctx" + let elpi_constant_type_tctxc = Elpi.API.RawData.Constants.declare_global_symbol - elpi_constant_constructor_ctx_Entry - module Elpi_ctx_Map = (Elpi.API.Utils.Map.Make)(String) - let elpi_ctx_state = - Elpi.API.State.declare ~name:"ctx" + elpi_constant_type_tctx + let elpi_constant_constructor_tctx_Entry = "entry" + let elpi_constant_constructor_tctx_Entryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tctx_Entry + module Elpi_tctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_tctx_state = + Elpi.API.State.declare ~name:"tctx" ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") ~init:(fun () -> - ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant - Elpi_ctx_Map.t), - (Elpi.API.RawData.Constants.Map.empty : ctx - Elpi.API.ContextualConversion.ctx_entry + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.Conversion.ctx_entry Elpi.API.RawData.Constants.Map.t))) - let elpi_ctx_to_key ~depth:_ = - function | Entry (elpi__48, _) -> elpi__48 - let elpi_is_ctx ~depth:elpi__depth elpi__x = + let elpi_tctx_to_key ~depth:_ = + function | Entry (elpi__63, _) -> elpi__63 + let elpi_is_tctx { Elpi.API.Data.hdepth = elpi__depth; hsrc = elpi__x } = match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const _ -> None | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> - if false || (elpi__hd == elpi_constant_constructor_ctx_Entryc) + if false || (elpi__hd == elpi_constant_constructor_tctx_Entryc) then (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with | Elpi.API.RawData.Const x -> Some x @@ -513,59 +461,69 @@ include "context entry applied to a non nominal") else None | _ -> None - let elpi_push_ctx ~depth:elpi__depth elpi__state elpi__name + let elpi_push_tctx ~depth:elpi__depth elpi__state elpi__name elpi__ctx_item = let (elpi__ctx2dbl, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in let elpi__i = elpi__depth in - let elpi__ctx2dbl = Elpi_ctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__ctx2dbl = Elpi_tctx_Map.add elpi__name elpi__i elpi__ctx2dbl in let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item elpi__dbl2ctx in let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state + Elpi.API.State.set elpi_tctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state - let elpi_pop_ctx ~depth:elpi__depth elpi__state elpi__name = + let elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__name = let (elpi__ctx2dbl, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in let elpi__i = elpi__depth in - let elpi__ctx2dbl = Elpi_ctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__ctx2dbl = Elpi_tctx_Map.remove elpi__name elpi__ctx2dbl in let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state + Elpi.API.State.set elpi_tctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state - let rec elpi_embed_ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + module Ctx_for_tctx = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tyctx.t + method tyctx : tyctx Elpi.API.Conversion.ctx_field + end + end + let rec elpi_embed_tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> fun elpi__state -> function - | (elpi__57, Entry (elpi__55, elpi__56)) -> + | (elpi__56, Entry (elpi__54, elpi__55)) -> + let (elpi__state, elpi__60, elpi__57) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__56 in let (elpi__state, elpi__61, elpi__58) = - Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__57 in - let (elpi__state, elpi__62, elpi__59) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__55 in - let (elpi__state, elpi__63, elpi__60) = - ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__56 in + elpi__constraints elpi__state elpi__54 in + let (elpi__state, elpi__62, elpi__59) = + ty.Elpi.API.Conversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__55 in (elpi__state, (Elpi.API.RawData.mkAppL - elpi_constant_constructor_ctx_Entryc - [elpi__61; elpi__62; elpi__63]), - (List.concat [elpi__58; elpi__59; elpi__60])) - let rec elpi_readback_ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + elpi_constant_constructor_tctx_Entryc + [elpi__60; elpi__61; elpi__62]), + (List.concat [elpi__57; elpi__58; elpi__59])) + let rec elpi_readback_tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> @@ -574,126 +532,103 @@ include fun elpi__x -> match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when - elpi__hd == elpi_constant_constructor_ctx_Entryc -> - let (elpi__state, elpi__54, elpi__53) = - Elpi.API.PPX.readback_nominal ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__x in + elpi__hd == elpi_constant_constructor_tctx_Entryc -> + let (elpi__state, elpi__53, elpi__52) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in (match elpi__xs with - | elpi__49::elpi__50::[] -> - let (elpi__state, elpi__49, elpi__51) = + | elpi__48::elpi__49::[] -> + let (elpi__state, elpi__48, elpi__50) = Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__48 in + let (elpi__state, elpi__49, elpi__51) = + ty.Elpi.API.Conversion.readback ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__49 in - let (elpi__state, elpi__50, elpi__52) = - ty.Elpi.API.ContextualConversion.readback - ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state elpi__50 in (elpi__state, - (elpi__54, (Entry (elpi__49, elpi__50))), - (List.concat [elpi__53; elpi__51; elpi__52])) + (elpi__53, (Entry (elpi__48, elpi__49))), + (List.concat [elpi__52; elpi__50; elpi__51])) | _ -> Elpi.API.Utils.type_error ("Not enough arguments to constructor: " ^ (Elpi.API.RawData.Constants.show - elpi_constant_constructor_ctx_Entryc))) + elpi_constant_constructor_tctx_Entryc))) | _ -> Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" - "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + "tctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "ctx" in + let kind = Elpi.API.Conversion.TyName "tctx" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> - Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; Elpi.API.PPX.Doc.constructor fmt - ~ty:(Elpi.API.ContextualConversion.TyName "prop") - ~name:"entry" ~doc:"Entry" - ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - ty.Elpi.API.ContextualConversion.ty]); - pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); - embed = elpi_embed_ctx; - readback = elpi_readback_ctx + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"entry" + ~doc:"Entry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + ty.Elpi.API.Conversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); + embed = elpi_embed_tctx; + readback = elpi_readback_tctx } - let in_ctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state = - let module CMap = Elpi.API.RawData.Constants.Map in - let elpi__filtered_hyps = - List.fold_left - (fun elpi__m -> - fun - ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as - elpi__hyp) - -> - match elpi_is_ctx ~depth:elpi__i elpi__hsrc with - | None -> elpi__m - | Some elpi__idx -> - (if CMap.mem elpi__idx elpi__m - then - Elpi.API.Utils.type_error - "more than one context entry for the same nominal"; - CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty - (Elpi.API.RawData.of_hyps elpi__hyps) in - let rec elpi__aux elpi__state elpi__gls elpi__i = - if elpi__i = elpi__depth - then (elpi__state, (List.concat (List.rev elpi__gls))) - else - if not (CMap.mem elpi__i elpi__filtered_hyps) - then elpi__aux elpi__state elpi__gls (elpi__i + 1) - else - (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in - let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in - let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = - ctx.Elpi.API.ContextualConversion.readback - ~depth:elpi__hyp_depth elpi__hyps elpi__constraints - elpi__state elpi__hyp.Elpi.API.RawData.hsrc in - assert (elpi__nominal = elpi__i); - (let elpi__s = elpi_ctx_to_key ~depth:elpi__hyp_depth elpi__t in - let elpi__state = - elpi_push_ctx ~depth:elpi__i elpi__state elpi__s - { - Elpi.API.ContextualConversion.entry = elpi__t; - depth = elpi__hyp_depth - } in - elpi__aux elpi__state (elpi__gls_t :: elpi__gls) - (elpi__i + 1))) in - let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state - (Elpi_ctx_Map.empty, CMap.empty) in - let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in - let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in - (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) - let in_ctx = - Elpi.API.ContextualConversion.(|+|) in_tctx_alone in_ctx_alone - let elpi_ctx = Elpi.API.BuiltIn.MLDataC ctx - let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_ctx] @ [])) + let context_made_of_tctx = + { + Elpi.API.Conversion.is_entry_for_nominal = elpi_is_tctx; + to_key = elpi_tctx_to_key; + push = elpi_push_tctx; + pop = elpi_pop_tctx; + conv = tctx; + init = + (fun state -> + Elpi.API.State.set elpi_tctx_state state + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.Conversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))); + get = + (fun state -> snd @@ (Elpi.API.State.get elpi_tctx_state state)) + } + let elpi_tctx = Elpi.API.BuiltIn.MLData tctx + class ctx_for_tctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tctx.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tyctx) h s) + method tyctx = context_made_of_tyctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_tctx : Ctx_for_tctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tyctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tyctx + ctx h c s in + (s, ((new ctx_for_tctx) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_tctx]) end[@@ocaml.doc "@inline"][@@merlin.hide ] let pp_term _ _ = () type term = - | Var of string [@elpi.var ] + | Var of string [@elpi.var tctx] | App of term * term | Lam of ty * string * - ((term)[@elpi.binder fun b -> fun s -> Entry (s, b)]) [@@deriving - elpi - { - append = - elpi_stuff; - context = - (() : - ((ty -> tctx) - * - (term -> - ctx))) - }] + ((term)[@elpi.binder tctx (fun b -> fun s -> Entry (s, b))]) [@@deriving + elpi + { + declaration + }] include struct [@@@warning "-26-27-32-39-60"] @@ -713,11 +648,17 @@ include let elpi_constant_constructor_term_Lamc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_term_Lam + module Ctx_for_term = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -725,13 +666,13 @@ include function | Var elpi__76 -> let (elpi__ctx2dbl, _) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in let elpi__key = (fun x -> x) elpi__76 in - (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) then Elpi.API.Utils.error "Unbound variable"; (elpi__state, (Elpi.API.RawData.mkBound - (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) | App (elpi__79, elpi__80) -> let (elpi__state, elpi__83, elpi__81) = elpi_embed_term ~depth:elpi__depth elpi__hyps @@ -746,7 +687,7 @@ include (List.concat [elpi__81; elpi__82])) | Lam (elpi__85, elpi__86, elpi__87) -> let (elpi__state, elpi__91, elpi__88) = - ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth + ty.Elpi.API.Conversion.embed ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__85 in let (elpi__state, elpi__92, elpi__89) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps @@ -754,21 +695,21 @@ include let elpi__ctx_entry = (fun b -> fun s -> Entry (s, b)) elpi__85 elpi__86 in let elpi__ctx_key = - elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = - elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state elpi__ctx_key elpi__ctx_entry in let (elpi__state, elpi__94, elpi__90) = elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps elpi__constraints elpi__state elpi__87 in let elpi__93 = Elpi.API.RawData.mkLam elpi__94 in let elpi__state = - elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state elpi__ctx_key in (elpi__state, (Elpi.API.RawData.mkAppL @@ -776,10 +717,7 @@ include [elpi__91; elpi__92; elpi__93]), (List.concat [elpi__88; elpi__89; elpi__90])) let rec elpi_readback_term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -788,7 +726,7 @@ include match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in (if not (Elpi.API.RawData.Constants.Map.mem elpi__hd @@ -798,16 +736,16 @@ include (Format.asprintf "Unbound variable: %s in %a" (Elpi.API.RawData.Constants.show elpi__hd) (Elpi.API.RawData.Constants.Map.pp - (Elpi.API.ContextualConversion.pp_ctx_entry - pp_ctx)) elpi__dbl2ctx); - (let { - Elpi.API.ContextualConversion.entry = elpi__entry; + (Elpi.API.Conversion.pp_ctx_entry pp_tctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd elpi__dbl2ctx in (elpi__state, - (Var (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + (Var + (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), []))) | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_term_Appc -> @@ -829,9 +767,8 @@ include | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_term_Lamc -> let (elpi__state, elpi__75, elpi__74) = - ty.Elpi.API.ContextualConversion.readback - ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state elpi__x in + ty.Elpi.API.Conversion.readback ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in (match elpi__xs with | elpi__70::elpi__71::[] -> let (elpi__state, elpi__70, elpi__72) = @@ -841,15 +778,15 @@ include let elpi__ctx_entry = (fun b -> fun s -> Entry (s, b)) elpi__75 elpi__70 in let elpi__ctx_key = - elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + elpi_tctx_to_key ~depth:elpi__depth + elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = - elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = - elpi_push_ctx ~depth:elpi__depth elpi__state + elpi_push_tctx ~depth:elpi__depth elpi__state elpi__ctx_key elpi__ctx_entry in let (elpi__state, elpi__71, elpi__73) = match Elpi.API.RawData.look ~depth:elpi__depth @@ -861,7 +798,7 @@ include elpi__bo | _ -> assert false in let elpi__state = - elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__ctx_key in (elpi__state, (Lam (elpi__75, elpi__70, elpi__71)), (List.concat [elpi__74; elpi__72; elpi__73])) @@ -874,80 +811,82 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "term" in + let term : 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "term" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"app" ~doc:"App" - ~args:[Elpi.API.ContextualConversion.TyName - elpi_constant_type_term; - Elpi.API.ContextualConversion.TyName - elpi_constant_type_term]; + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_term; + Elpi.API.Conversion.TyName elpi_constant_type_term]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" ~doc:"Lam" - ~args:[ty.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyApp - ("->", - (Elpi.API.ContextualConversion.TyName "term"), - [Elpi.API.ContextualConversion.TyName + ~args:[ty.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "term"), + [Elpi.API.Conversion.TyName elpi_constant_type_term])]); pp = pp_term; embed = elpi_embed_term; readback = elpi_readback_term } - let elpi_term = Elpi.API.BuiltIn.MLDataC term - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_term] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.term i:term, o:term."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" - "" "var" "A0" "var" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" - "" "app" "A0 A1" "app" "B0 B1" - (String.concat ", " - ["(" ^ - (("map." ^ elpi_constant_type_term) ^ - (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - (("map." ^ elpi_constant_type_term) ^ - (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" - "" "lam" "A0 A1 A2" "lam" "B0 B1 B2" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")"))))); - Printf.sprintf "(pi x fixme x => (=) %s %s)" "A2" - "B2"]); - "\n"])])) + let elpi_term = Elpi.API.BuiltIn.MLData term + class ctx_for_term (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_term.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_term : Ctx_for_term.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx + h c s in + (s, ((new ctx_for_term) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_term]) end[@@ocaml.doc "@inline"][@@merlin.hide ] +let _ = fun (f : #ctx_for_tctx -> unit) -> fun (x : ctx_for_term) -> f x open Elpi.API -let in_ctx - : ((tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx - ContextualConversion.ctx_entry RawData.Constants.Map.t), - Data.constraints) ContextualConversion.ctx_readback - = in_ctx -let builtin = - let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +open BuiltInPredicate +open Notation +let term_to_string = + Pred + ("term->string", + (In (term, "T", (Out (BuiltInData.string, "S", (Read "what else"))))), + in_ctx_for_term, + (fun (t : term) -> + fun (_ety : string oarg) -> + fun ~depth:_ -> + fun c -> + fun (_cst : Data.constraints) -> + fun (_state : State.t) -> + !: + (Format.asprintf "@[%a@ ; %a@ |-@ %a@]@\n%!" + (RawData.Constants.Map.pp + (Conversion.pp_ctx_entry pp_tctx)) c#tyctx + (RawData.Constants.Map.pp + (Conversion.pp_ctx_entry pp_tctx)) c#tctx + term.pp t))) +let builtin1 = + let open BuiltIn in + declare ~file_name:"test_ppx.elpi" + ((!declaration) @ + ([MLCode (term_to_string, DocAbove); + LPDoc "----------------- elpi ----------------"] @ + (let open Elpi.Builtin in core_builtins @ elpi_builtins))) +let builtin2 = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!declaration) let main () = - let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in - BuiltIn.document_file builtin; exit 0 + let (_elpi, _) = Setup.init ~builtins:[builtin1; builtin2] ~basedir:"." [] in + BuiltIn.document_file builtin2; exit 0 ;;main () diff --git a/ppx_elpi/tests/test_double_contextual.ml b/ppx_elpi/tests/test_double_contextual.ml index e5201fff9..f55051bd8 100644 --- a/ppx_elpi/tests/test_double_contextual.ml +++ b/ppx_elpi/tests/test_double_contextual.ml @@ -1,4 +1,4 @@ -let elpi_stuff = ref [] +let declaration = ref [] module String = struct include String @@ -6,40 +6,70 @@ module String = struct let show = Format.asprintf "%a" pp end -let pp_tctx _ _ = () -type tctx = TEntry of (string[@elpi.key]) * bool -[@@deriving elpi { append = elpi_stuff; index = (module String) }] +let pp_tyctx _ _ = () +type tyctx = TEntry of (string[@elpi.key]) * bool +[@@elpi.index (module String)] +[@@deriving elpi { declaration }] + let pp_ty _ _ = () type ty = - | TVar of string [@elpi.var] + | TVar of string [@elpi.var tyctx] | TApp of string * ty - | TAll of bool * string * (ty[@elpi.binder (fun b s -> TEntry(s,b))]) -[@@deriving elpi { append = elpi_stuff; context = (() : ty -> tctx) }] + | TAll of bool * string * (ty[@elpi.binder tyctx (fun b s -> TEntry(s,b))]) +[@@deriving elpi { declaration; }] + -let pp_ctx _ _ = () -type ctx = Entry of (string[@elpi.key]) * ty -[@@deriving elpi { append = elpi_stuff; index = (module String); context = (() : tctx) } ] +let pp_tctx _ _ = () +type tctx = Entry of (string[@elpi.key]) * ty +[@@elpi.index (module String)] +[@@deriving elpi { declaration ; context = [tyctx]} ] + let pp_term _ _ = () type term = - | Var of string [@elpi.var] + | Var of string [@elpi.var tctx] | App of term * term - | Lam of ty * string * (term[@elpi.binder (fun b s -> Entry(s,b))]) -[@@deriving elpi { append = elpi_stuff; context = (() : (ty -> tctx) * (term -> ctx)) }] + | Lam of ty * string * (term[@elpi.binder tctx (fun b s -> Entry(s,b))]) +[@@deriving elpi { declaration }] + +let _ = + fun (f : #ctx_for_tctx -> unit) -> + fun (x : ctx_for_term) -> + f x + open Elpi.API +open BuiltInPredicate +open Notation + +let term_to_string = Pred("term->string", + In(term,"T", + Out(BuiltInData.string,"S", + Read("what else"))),in_ctx_for_term, + fun (t : term) (_ety : string oarg) + ~depth:_ c (_cst : Data.constraints) (_state : State.t) -> + + !: (Format.asprintf "@[%a@ ; %a@ |-@ %a@]@\n%!" + (RawData.Constants.Map.pp (Conversion.pp_ctx_entry pp_tctx)) c#tyctx + (RawData.Constants.Map.pp (Conversion.pp_ctx_entry pp_tctx)) c#tctx + term.pp t) -let in_ctx : (tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx ContextualConversion.ctx_entry RawData.Constants.Map.t, Data.constraints) ContextualConversion.ctx_readback = in_ctx +) -let builtin = let open BuiltIn in - declare ~file_name:(Sys.argv.(1)) !elpi_stuff +let builtin1 = let open BuiltIn in + declare ~file_name:"test_ppx.elpi" (!declaration @ [ + MLCode(term_to_string,DocAbove); + LPDoc "----------------- elpi ----------------" + ] @ Elpi.Builtin.(core_builtins @ elpi_builtins)) + +let builtin2 = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !declaration let main () = - let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in - BuiltIn.document_file builtin; + let _elpi, _ = Setup.init ~builtins:[builtin1;builtin2] ~basedir:"." [] in + BuiltIn.document_file builtin2; exit 0 ;; - -main () \ No newline at end of file +main () diff --git a/ppx_elpi/tests/test_mutual_adt.expected.elpi b/ppx_elpi/tests/test_mutual_adt.expected.elpi index 0ed87d886..2ab1d84fb 100644 --- a/ppx_elpi/tests/test_mutual_adt.expected.elpi +++ b/ppx_elpi/tests/test_mutual_adt.expected.elpi @@ -10,18 +10,6 @@ kind mut type. type c mut. % C type d simple -> mut. % D -pred map.simple i:simple, o:simple. -map.simple a a. -map.simple (b A0 A1) (b B0 B1) :- ((=) A0 B0), (map.mut A1 B1). - - - -pred map.mut i:mut, o:mut. -map.mut c c. -map.mut (d A0) (d B0) :- (map.simple A0 B0). - - - diff --git a/ppx_elpi/tests/test_mutual_adt.expected.ml b/ppx_elpi/tests/test_mutual_adt.expected.ml index 30ec22fdc..6dcb0b170 100644 --- a/ppx_elpi/tests/test_mutual_adt.expected.ml +++ b/ppx_elpi/tests/test_mutual_adt.expected.ml @@ -6,7 +6,7 @@ type simple = | B of int * mut and mut = | C - | D of simple [@@deriving elpi { append = elpi_stuff }] + | D of simple [@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -33,11 +33,12 @@ include let elpi_constant_constructor_mut_Dc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_mut_D + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end + module Ctx_for_mut = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -61,10 +62,7 @@ include [elpi__9; elpi__10]), (List.concat [elpi__7; elpi__8])) and elpi_embed_mut : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (mut, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (mut, #Ctx_for_mut.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -82,10 +80,7 @@ include (Elpi.API.RawData.mkAppL elpi_constant_constructor_mut_Dc [elpi__15]), (List.concat [elpi__14])) let rec elpi_readback_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -117,10 +112,7 @@ include (Format.asprintf "Not a constructor of type %s: %a" "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) and elpi_readback_mut : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (mut, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (mut, #Ctx_for_mut.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -148,14 +140,11 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "mut" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t + let simple : 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "simple" in + let kind = Elpi.API.Conversion.TyName "simple" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> @@ -163,22 +152,16 @@ include Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"a" ~doc:"A" ~args:[]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"b" ~doc:"B" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyName - elpi_constant_type_mut]); + ~args:[Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyName elpi_constant_type_mut]); pp = pp_simple; embed = elpi_embed_simple; readback = elpi_readback_simple } - let mut : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (mut, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "mut" in + let mut : 'c . (mut, #Ctx_for_mut.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "mut" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> @@ -186,42 +169,28 @@ include Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"c" ~doc:"C" ~args:[]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"d" ~doc:"D" - ~args:[Elpi.API.ContextualConversion.TyName - elpi_constant_type_simple]); + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_simple]); pp = pp_mut; embed = elpi_embed_mut; readback = elpi_readback_mut } - let elpi_simple = Elpi.API.BuiltIn.MLDataC simple - let elpi_mut = Elpi.API.BuiltIn.MLDataC mut - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple; elpi_mut] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:simple, o:simple."; - "map.simple a a."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "" "b" "A0 A1" "b" "B0 B1" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - (("map." ^ elpi_constant_type_mut) ^ - (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - "\n"]); - Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.mut i:mut, o:mut."; - "map.mut c c."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "mut" "" - "d" "A0" "d" "B0" - (String.concat ", " - ["(" ^ - (("map." ^ elpi_constant_type_simple) ^ - (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - "\n"])])) + let elpi_simple = Elpi.API.BuiltIn.MLData simple + let elpi_mut = Elpi.API.BuiltIn.MLData mut + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + class ctx_for_mut (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_mut.t = object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_mut : Ctx_for_mut.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_mut) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple; elpi_mut]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API let builtin = diff --git a/ppx_elpi/tests/test_mutual_adt.ml b/ppx_elpi/tests/test_mutual_adt.ml index bb3fa4331..db179ce32 100644 --- a/ppx_elpi/tests/test_mutual_adt.ml +++ b/ppx_elpi/tests/test_mutual_adt.ml @@ -4,7 +4,7 @@ let pp_simple _ _ = () let pp_mut _ _ = () type simple = A | B of int * mut and mut = C | D of simple -[@@deriving elpi { append = elpi_stuff }] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API diff --git a/ppx_elpi/tests/test_mutual_contextual.expected.elpi b/ppx_elpi/tests/test_mutual_contextual.expected.elpi new file mode 100644 index 000000000..e69de29bb diff --git a/ppx_elpi/tests/test_mutual_contextual.expected.ml b/ppx_elpi/tests/test_mutual_contextual.expected.ml new file mode 100644 index 000000000..1b50076a8 --- /dev/null +++ b/ppx_elpi/tests/test_mutual_contextual.expected.ml @@ -0,0 +1,684 @@ +let declaration = ref [] +module String = + struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show = Format.asprintf "%a" pp + end +type term = + | Var of string [@elpi.var ctx] + | App of term * term + | Tapp of term * ty + | Lam of ty * string * + ((term)[@elpi.binder ctx (fun b -> fun s -> Entry (s, b))]) +and ty = + | TVar of string [@elpi.var ctx] + | TIdx of ty * term + | TAbs of string * bool * + ((ty)[@elpi.binder ctx (fun s -> fun b -> TEntry (s, b))]) +and ctx = + | Entry of ((string)[@elpi.index ]) * ty + | TEentry of ((string)[@elpi.index ]) * bool [@@elpi.index (module String)] +[@@deriving elpi { declaration }] +include + struct + [@@@warning "-26-27-32-39-60"] + let elpi_constant_type_term = "term" + let elpi_constant_type_termc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_type_term + let elpi_constant_constructor_term_Var = "var" + let elpi_constant_constructor_term_Varc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Var + let elpi_constant_constructor_term_App = "app" + let elpi_constant_constructor_term_Appc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_App + let elpi_constant_constructor_term_Tapp = "tapp" + let elpi_constant_constructor_term_Tappc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Tapp + let elpi_constant_constructor_term_Lam = "lam" + let elpi_constant_constructor_term_Lamc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Lam + let elpi_constant_type_ty = "ty" + let elpi_constant_type_tyc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ty + let elpi_constant_constructor_ty_TVar = "tvar" + let elpi_constant_constructor_ty_TVarc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TVar + let elpi_constant_constructor_ty_TIdx = "tidx" + let elpi_constant_constructor_ty_TIdxc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TIdx + let elpi_constant_constructor_ty_TAbs = "tabs" + let elpi_constant_constructor_ty_TAbsc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TAbs + let elpi_constant_type_ctx = "ctx" + let elpi_constant_type_ctxc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ctx + let elpi_constant_constructor_ctx_Entry = "entry" + let elpi_constant_constructor_ctx_Entryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ctx_Entry + let elpi_constant_constructor_ctx_TEentry = "teentry" + let elpi_constant_constructor_ctx_TEentryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ctx_TEentry + module Ctx_for_term = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_ctx.t + method ctx : ctx Elpi.API.Conversion.ctx_field + end + end + module Ctx_for_ty = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_ctx.t + method ctx : ctx Elpi.API.Conversion.ctx_field + end + end + module Ctx_for_ctx = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_ctx.t + method ctx : ctx Elpi.API.Conversion.ctx_field + end + end + let rec elpi_embed_term : + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.embedding = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | Var elpi__17 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__17 in + (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | App (elpi__20, elpi__21) -> + let (elpi__state, elpi__24, elpi__22) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__20 in + let (elpi__state, elpi__25, elpi__23) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__21 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Appc + [elpi__24; elpi__25]), + (List.concat [elpi__22; elpi__23])) + | Tapp (elpi__26, elpi__27) -> + let (elpi__state, elpi__30, elpi__28) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__26 in + let (elpi__state, elpi__31, elpi__29) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__27 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Tappc + [elpi__30; elpi__31]), + (List.concat [elpi__28; elpi__29])) + | Lam (elpi__32, elpi__33, elpi__34) -> + let (elpi__state, elpi__38, elpi__35) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__32 in + let (elpi__state, elpi__39, elpi__36) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__33 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__32 elpi__33 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__41, elpi__37) = + elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__34 in + let elpi__40 = Elpi.API.RawData.mkLam elpi__41 in + let elpi__state = + elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_term_Lamc + [elpi__38; elpi__39; elpi__40]), + (List.concat [elpi__35; elpi__36; elpi__37])) + and elpi_embed_ty : + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.embedding = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | TVar elpi__54 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_ctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__54 in + (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | TIdx (elpi__57, elpi__58) -> + let (elpi__state, elpi__61, elpi__59) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__57 in + let (elpi__state, elpi__62, elpi__60) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__58 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ty_TIdxc + [elpi__61; elpi__62]), + (List.concat [elpi__59; elpi__60])) + | TAbs (elpi__63, elpi__64, elpi__65) -> + let (elpi__state, elpi__69, elpi__66) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__63 in + let (elpi__state, elpi__70, elpi__67) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__64 in + let elpi__ctx_entry = + (fun s -> fun b -> TEntry (s, b)) elpi__63 elpi__64 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__72, elpi__68) = + elpi_embed_ty ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__65 in + let elpi__71 = Elpi.API.RawData.mkLam elpi__72 in + let elpi__state = + elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ty_TAbsc + [elpi__69; elpi__70; elpi__71]), + (List.concat [elpi__66; elpi__67; elpi__68])) + and elpi_embed_ctx : + 'c . + ((Elpi.API.RawData.constant * ctx), #Ctx_for_ctx.t as 'c) + Elpi.API.Conversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__87, Entry (elpi__85, elpi__86)) -> + let (elpi__state, elpi__91, elpi__88) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__87 in + let (elpi__state, elpi__92, elpi__89) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__85 in + let (elpi__state, elpi__93, elpi__90) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__86 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ctx_Entryc + [elpi__91; elpi__92; elpi__93]), + (List.concat [elpi__88; elpi__89; elpi__90])) + | (elpi__96, TEentry (elpi__94, elpi__95)) -> + let (elpi__state, elpi__100, elpi__97) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__96 in + let (elpi__state, elpi__101, elpi__98) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__94 in + let (elpi__state, elpi__102, elpi__99) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__95 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_ctx_TEentryc + [elpi__100; elpi__101; elpi__102]), + (List.concat [elpi__97; elpi__98; elpi__99])) + let rec elpi_readback_term : + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.readback = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.Conversion.pp_ctx_entry pp_ctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (Var (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Appc -> + let (elpi__state, elpi__6, elpi__5) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__3::[] -> + let (elpi__state, elpi__3, elpi__4) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__3 in + (elpi__state, (App (elpi__6, elpi__3)), + (List.concat [elpi__5; elpi__4])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Appc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Tappc -> + let (elpi__state, elpi__10, elpi__9) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__7::[] -> + let (elpi__state, elpi__7, elpi__8) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__7 in + (elpi__state, (Tapp (elpi__10, elpi__7)), + (List.concat [elpi__9; elpi__8])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Tappc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Lamc -> + let (elpi__state, elpi__16, elpi__15) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__11::elpi__12::[] -> + let (elpi__state, elpi__11, elpi__13) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__11 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__16 elpi__11 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__12, elpi__14) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__12 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_term ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (Lam (elpi__16, elpi__11, elpi__12)), + (List.concat [elpi__15; elpi__13; elpi__14])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Lamc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) + and elpi_readback_ty : + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.readback = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_ctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.Conversion.pp_ctx_entry pp_ctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (TVar + (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_TIdxc -> + let (elpi__state, elpi__47, elpi__46) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__44::[] -> + let (elpi__state, elpi__44, elpi__45) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__44 in + (elpi__state, (TIdx (elpi__47, elpi__44)), + (List.concat [elpi__46; elpi__45])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_TIdxc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_TAbsc -> + let (elpi__state, elpi__53, elpi__52) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__48::elpi__49::[] -> + let (elpi__state, elpi__48, elpi__50) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__48 in + let elpi__ctx_entry = + (fun s -> fun b -> TEntry (s, b)) elpi__53 + elpi__48 in + let elpi__ctx_key = + elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__49, elpi__51) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__49 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_ty ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (TAbs (elpi__53, elpi__48, elpi__49)), + (List.concat [elpi__52; elpi__50; elpi__51])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_TAbsc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ty" (Elpi.API.RawPp.term elpi__depth) elpi__x) + and elpi_readback_ctx : + 'c . + ((Elpi.API.RawData.constant * ctx), #Ctx_for_ctx.t as 'c) + Elpi.API.Conversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ctx_Entryc -> + let (elpi__state, elpi__78, elpi__77) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | elpi__73::elpi__74::[] -> + let (elpi__state, elpi__73, elpi__75) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__73 in + let (elpi__state, elpi__74, elpi__76) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__74 in + (elpi__state, + (elpi__78, (Entry (elpi__73, elpi__74))), + (List.concat [elpi__77; elpi__75; elpi__76])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ctx_Entryc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ctx_TEentryc -> + let (elpi__state, elpi__84, elpi__83) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | elpi__79::elpi__80::[] -> + let (elpi__state, elpi__79, elpi__81) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__79 in + let (elpi__state, elpi__80, elpi__82) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__80 in + (elpi__state, + (elpi__84, (TEentry (elpi__79, elpi__80))), + (List.concat [elpi__83; elpi__81; elpi__82])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ctx_TEentryc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" + "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let term : 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "term" in + { + Elpi.API.Conversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; + (Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"app" + ~doc:"App" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_term; + Elpi.API.Conversion.TyName elpi_constant_type_term]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tapp" + ~doc:"Tapp" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_term; + Elpi.API.Conversion.TyName elpi_constant_type_ty]); + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" + ~doc:"Lam" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "term"), + [Elpi.API.Conversion.TyName + elpi_constant_type_term])]); + pp = pp_term; + embed = elpi_embed_term; + readback = elpi_readback_term + } + let ty : 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "ty" in + { + Elpi.API.Conversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ty"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tidx" + ~doc:"TIdx" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_ty; + Elpi.API.Conversion.TyName elpi_constant_type_term]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tabs" + ~doc:"TAbs" + ~args:[Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "ty"), + [Elpi.API.Conversion.TyName elpi_constant_type_ty])]); + pp = pp_ty; + embed = elpi_embed_ty; + readback = elpi_readback_ty + } + let ctx : + 'c . + ((Elpi.API.RawData.constant * ctx), #Ctx_for_ctx.t as 'c) + Elpi.API.Conversion.t + = + let kind = Elpi.API.Conversion.TyName "ctx" in + { + Elpi.API.Conversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"entry" + ~doc:"Entry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyName elpi_constant_type_ty]; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"teentry" + ~doc:"TEentry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); + embed = elpi_embed_ctx; + readback = elpi_readback_ctx + } + let elpi_term = Elpi.API.BuiltIn.MLData term + let elpi_ty = Elpi.API.BuiltIn.MLData ty + let elpi_ctx = Elpi.API.BuiltIn.MLData ctx + class ctx_for_term (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_term.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_ctx) h s) + method ctx = context_made_of_ctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_term : Ctx_for_term.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_ctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_ctx ctx + h c s in + (s, ((new ctx_for_term) h s), (List.concat [gls0])) + class ctx_for_ty (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_ty.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_ctx) h s) + method ctx = context_made_of_ctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_ty : Ctx_for_ty.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_ctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_ctx ctx + h c s in + (s, ((new ctx_for_ty) h s), (List.concat [gls0])) + class ctx_for_ctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_ctx.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_ctx) h s) + method ctx = context_made_of_ctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_ctx : Ctx_for_ctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_ctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_ctx ctx + h c s in + (s, ((new ctx_for_ctx) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_term; elpi_ty; elpi_ctx]) + end[@@ocaml.doc "@inline"][@@merlin.hide ] +open Elpi.API +let in_ctx + : ((tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx + ContextualConversion.ctx_entry RawData.Constants.Map.t), + Data.constraints) ContextualConversion.ctx_readback + = in_ctx +let builtin = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!declaration) +let main () = + let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; exit 0 +;;main () diff --git a/ppx_elpi/tests/test_mutual_contextual.ml b/ppx_elpi/tests/test_mutual_contextual.ml new file mode 100644 index 000000000..76cccfa3c --- /dev/null +++ b/ppx_elpi/tests/test_mutual_contextual.ml @@ -0,0 +1,712 @@ +let declaration = ref [] + +module String = struct + include String + let pp fmt s = Format.fprintf fmt "%s" s + let show = Format.asprintf "%a" pp +end + +type term = + | Var of string [@elpi.var tctx] + | App of term * term + | Tapp of term * ty + | Lam of ty * string * (term[@elpi.binder tctx (fun b s -> Entry(s,b))]) +and ty = + | TVar of string [@elpi.var tctx] + | TIdx of ty * term + | TAbs of string * bool * (ty[@elpi.binder tctx (fun s b -> TEntry(s,b))]) +and tctx = + | Entry of (string[@elpi.index]) * ty + | TEentry of (string[@elpi.index]) * bool + [@@elpi.index (module String)] +[@@deriving_inline elpi { declaration }] +[@@@warning "-26-27-32-39-60"] +let elpi_constant_type_term = "term" +let elpi_constant_type_termc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_term +let elpi_constant_constructor_term_Var = "var" +let elpi_constant_constructor_term_Varc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Var +let elpi_constant_constructor_term_App = "app" +let elpi_constant_constructor_term_Appc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_App +let elpi_constant_constructor_term_Tapp = "tapp" +let elpi_constant_constructor_term_Tappc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Tapp +let elpi_constant_constructor_term_Lam = "lam" +let elpi_constant_constructor_term_Lamc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_term_Lam +let elpi_constant_type_ty = "ty" +let elpi_constant_type_tyc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ty +let elpi_constant_constructor_ty_TVar = "tvar" +let elpi_constant_constructor_ty_TVarc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TVar +let elpi_constant_constructor_ty_TIdx = "tidx" +let elpi_constant_constructor_ty_TIdxc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TIdx +let elpi_constant_constructor_ty_TAbs = "tabs" +let elpi_constant_constructor_ty_TAbsc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_ty_TAbs +let elpi_constant_type_tctx = "tctx" +let elpi_constant_type_tctxc = + Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_tctx +let elpi_constant_constructor_tctx_Entry = "entry" +let elpi_constant_constructor_tctx_Entryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tctx_Entry +let elpi_constant_constructor_tctx_TEentry = "teentry" +let elpi_constant_constructor_tctx_TEentryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tctx_TEentry +module Ctx_for_term = + +ONLY ONE + + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end +module Ctx_for_ty = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end +module Ctx_for_tctx = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end +let rec elpi_embed_term : + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.embedding = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | Var elpi__17 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__17 in + (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | App (elpi__20, elpi__21) -> + let (elpi__state, elpi__24, elpi__22) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__20 in + let (elpi__state, elpi__25, elpi__23) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__21 in + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_term_Appc + [elpi__24; elpi__25]), (List.concat [elpi__22; elpi__23])) + | Tapp (elpi__26, elpi__27) -> + let (elpi__state, elpi__30, elpi__28) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__26 in + let (elpi__state, elpi__31, elpi__29) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__27 in + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_term_Tappc + [elpi__30; elpi__31]), (List.concat [elpi__28; elpi__29])) + | Lam (elpi__32, elpi__33, elpi__34) -> + let (elpi__state, elpi__38, elpi__35) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__32 in + let (elpi__state, elpi__39, elpi__36) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__33 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__32 elpi__33 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__41, elpi__37) = + elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__34 in + let elpi__40 = Elpi.API.RawData.mkLam elpi__41 in + let elpi__state = + elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_term_Lamc + [elpi__38; elpi__39; elpi__40]), + (List.concat [elpi__35; elpi__36; elpi__37])) +and elpi_embed_ty : + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.embedding = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | TVar elpi__54 -> + let (elpi__ctx2dbl, _) = + Elpi.API.State.get elpi_tctx_state elpi__state in + let elpi__key = (fun x -> x) elpi__54 in + (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) + then Elpi.API.Utils.error "Unbound variable"; + (elpi__state, + (Elpi.API.RawData.mkBound + (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) + | TIdx (elpi__57, elpi__58) -> + let (elpi__state, elpi__61, elpi__59) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__57 in + let (elpi__state, elpi__62, elpi__60) = + elpi_embed_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__58 in + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_ty_TIdxc + [elpi__61; elpi__62]), (List.concat [elpi__59; elpi__60])) + | TAbs (elpi__63, elpi__64, elpi__65) -> + let (elpi__state, elpi__69, elpi__66) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__63 in + let (elpi__state, elpi__70, elpi__67) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__64 in + let elpi__ctx_entry = + (fun s -> fun b -> TEntry (s, b)) elpi__63 elpi__64 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__72, elpi__68) = + elpi_embed_ty ~depth:(elpi__depth + 1) elpi__hyps + elpi__constraints elpi__state elpi__65 in + let elpi__71 = Elpi.API.RawData.mkLam elpi__72 in + let elpi__state = + elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state + elpi__ctx_key in + (elpi__state, + (Elpi.API.RawData.mkAppL elpi_constant_constructor_ty_TAbsc + [elpi__69; elpi__70; elpi__71]), + (List.concat [elpi__66; elpi__67; elpi__68])) +and elpi_embed_tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.embedding + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + function + | (elpi__87, Entry (elpi__85, elpi__86)) -> + let (elpi__state, elpi__91, elpi__88) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state + elpi__87 in + let (elpi__state, elpi__92, elpi__89) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__85 in + let (elpi__state, elpi__93, elpi__90) = + elpi_embed_ty ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__86 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_tctx_Entryc + [elpi__91; elpi__92; elpi__93]), + (List.concat [elpi__88; elpi__89; elpi__90])) + | (elpi__96, TEentry (elpi__94, elpi__95)) -> + let (elpi__state, elpi__100, elpi__97) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state + elpi__96 in + let (elpi__state, elpi__101, elpi__98) = + Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__94 in + let (elpi__state, elpi__102, elpi__99) = + Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__95 in + (elpi__state, + (Elpi.API.RawData.mkAppL + elpi_constant_constructor_tctx_TEentryc + [elpi__100; elpi__101; elpi__102]), + (List.concat [elpi__97; elpi__98; elpi__99])) +let rec elpi_readback_term : + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.readback = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.Conversion.pp_ctx_entry pp_tctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (Var (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Appc -> + let (elpi__state, elpi__6, elpi__5) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__3::[] -> + let (elpi__state, elpi__3, elpi__4) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__3 in + (elpi__state, (App (elpi__6, elpi__3)), + (List.concat [elpi__5; elpi__4])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Appc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Tappc -> + let (elpi__state, elpi__10, elpi__9) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__7::[] -> + let (elpi__state, elpi__7, elpi__8) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__7 in + (elpi__state, (Tapp (elpi__10, elpi__7)), + (List.concat [elpi__9; elpi__8])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Tappc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_term_Lamc -> + let (elpi__state, elpi__16, elpi__15) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__11::elpi__12::[] -> + let (elpi__state, elpi__11, elpi__13) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__11 in + let elpi__ctx_entry = + (fun b -> fun s -> Entry (s, b)) elpi__16 elpi__11 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__12, elpi__14) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__12 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_term ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (Lam (elpi__16, elpi__11, elpi__12)), + (List.concat [elpi__15; elpi__13; elpi__14])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_term_Lamc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" "term" + (Elpi.API.RawPp.term elpi__depth) elpi__x) +and elpi_readback_ty : + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.readback = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> + let (_, elpi__dbl2ctx) = + Elpi.API.State.get elpi_tctx_state elpi__state in + (if + not + (Elpi.API.RawData.Constants.Map.mem elpi__hd + elpi__dbl2ctx) + then + Elpi.API.Utils.error + (Format.asprintf "Unbound variable: %s in %a" + (Elpi.API.RawData.Constants.show elpi__hd) + (Elpi.API.RawData.Constants.Map.pp + (Elpi.API.Conversion.pp_ctx_entry pp_tctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; + depth = elpi__depth } + = + Elpi.API.RawData.Constants.Map.find elpi__hd + elpi__dbl2ctx in + (elpi__state, + (TVar (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), + []))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_TIdxc -> + let (elpi__state, elpi__47, elpi__46) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__44::[] -> + let (elpi__state, elpi__44, elpi__45) = + elpi_readback_term ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__44 in + (elpi__state, (TIdx (elpi__47, elpi__44)), + (List.concat [elpi__46; elpi__45])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_TIdxc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_ty_TAbsc -> + let (elpi__state, elpi__53, elpi__52) = + Elpi.API.PPX.readback_string ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__x in + (match elpi__xs with + | elpi__48::elpi__49::[] -> + let (elpi__state, elpi__48, elpi__50) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__48 in + let elpi__ctx_entry = + (fun s -> fun b -> TEntry (s, b)) elpi__53 elpi__48 in + let elpi__ctx_key = + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in + let elpi__ctx_entry = + { + Elpi.API.Conversion.entry = elpi__ctx_entry; + depth = elpi__depth + } in + let elpi__state = + elpi_push_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key elpi__ctx_entry in + let (elpi__state, elpi__49, elpi__51) = + match Elpi.API.RawData.look ~depth:elpi__depth + elpi__49 + with + | Elpi.API.RawData.Lam elpi__bo -> + elpi_readback_ty ~depth:(elpi__depth + 1) + elpi__hyps elpi__constraints elpi__state + elpi__bo + | _ -> assert false in + let elpi__state = + elpi_pop_tctx ~depth:elpi__depth elpi__state + elpi__ctx_key in + (elpi__state, (TAbs (elpi__53, elpi__48, elpi__49)), + (List.concat [elpi__52; elpi__50; elpi__51])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_ty_TAbsc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" "ty" + (Elpi.API.RawPp.term elpi__depth) elpi__x) +and elpi_readback_tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.readback + = + fun ~depth:elpi__depth -> + fun elpi__hyps -> + fun elpi__constraints -> + fun elpi__state -> + fun elpi__x -> + match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_tctx_Entryc -> + let (elpi__state, elpi__78, elpi__77) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | elpi__73::elpi__74::[] -> + let (elpi__state, elpi__73, elpi__75) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__73 in + let (elpi__state, elpi__74, elpi__76) = + elpi_readback_ty ~depth:elpi__depth elpi__hyps + elpi__constraints elpi__state elpi__74 in + (elpi__state, (elpi__78, (Entry (elpi__73, elpi__74))), + (List.concat [elpi__77; elpi__75; elpi__76])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_tctx_Entryc))) + | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when + elpi__hd == elpi_constant_constructor_tctx_TEentryc -> + let (elpi__state, elpi__84, elpi__83) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in + (match elpi__xs with + | elpi__79::elpi__80::[] -> + let (elpi__state, elpi__79, elpi__81) = + Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__79 in + let (elpi__state, elpi__80, elpi__82) = + Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__80 in + (elpi__state, + (elpi__84, (TEentry (elpi__79, elpi__80))), + (List.concat [elpi__83; elpi__81; elpi__82])) + | _ -> + Elpi.API.Utils.type_error + ("Not enough arguments to constructor: " ^ + (Elpi.API.RawData.Constants.show + elpi_constant_constructor_tctx_TEentryc))) + | _ -> + Elpi.API.Utils.type_error + (Format.asprintf "Not a constructor of type %s: %a" "tctx" + (Elpi.API.RawPp.term elpi__depth) elpi__x) +let term : 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "term" in + { + Elpi.API.Conversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; + (Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"app" ~doc:"App" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_term; + Elpi.API.Conversion.TyName elpi_constant_type_term]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tapp" + ~doc:"Tapp" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_term; + Elpi.API.Conversion.TyName elpi_constant_type_ty]); + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" ~doc:"Lam" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "term"), + [Elpi.API.Conversion.TyName elpi_constant_type_term])]); + pp = pp_term; + embed = elpi_embed_term; + readback = elpi_readback_term + } +let ty : 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "ty" in + { + Elpi.API.Conversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"ty"; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tidx" ~doc:"TIdx" + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_ty; + Elpi.API.Conversion.TyName elpi_constant_type_term]; + Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tabs" ~doc:"TAbs" + ~args:[Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "ty"), + [Elpi.API.Conversion.TyName elpi_constant_type_ty])]); + pp = pp_ty; + embed = elpi_embed_ty; + readback = elpi_readback_ty + } +let tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.t + = + let kind = Elpi.API.Conversion.TyName "tctx" in + { + Elpi.API.Conversion.ty = kind; + pp_doc = + (fun fmt -> + fun () -> + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"entry" + ~doc:"Entry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyName elpi_constant_type_ty]; + Elpi.API.PPX.Doc.constructor fmt + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"teentry" + ~doc:"TEentry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); + embed = elpi_embed_tctx; + readback = elpi_readback_tctx + } +let elpi_term = Elpi.API.BuiltIn.MLData term +let elpi_ty = Elpi.API.BuiltIn.MLData ty +let elpi_tctx = Elpi.API.BuiltIn.MLData tctx +class ctx_for_term (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_term.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end +let (in_ctx_for_term : Ctx_for_term.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx h c + s in + (s, ((new ctx_for_term) h s), (List.concat [gls0])) +class ctx_for_ty (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_ty.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end +let (in_ctx_for_ty : Ctx_for_ty.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx h c + s in + (s, ((new ctx_for_ty) h s), (List.concat [gls0])) +class ctx_for_tctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tctx.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end +let (in_ctx_for_tctx : Ctx_for_tctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx h c + s in + (s, ((new ctx_for_tctx) h s), (List.concat [gls0])) +let () = declaration := ((!declaration) @ [elpi_term; elpi_ty; elpi_tctx]) +[@@@end] + +open Elpi.API + +let in_ctx_for_term : ctx_for_term Conversion.ctx_readback = in_ctx_for_term + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !declaration + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () +rsion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx h c + s in + (s, ((new ctx_for_ty) h s), (List.concat [gls0])) +let _ = in_ctx_for_ty +class ctx_for_tctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tctx.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end +let (in_ctx_for_tctx : Ctx_for_tctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx h c + s in + (s, ((new ctx_for_tctx) h s), (List.concat [gls0])) +let _ = in_ctx_for_tctx +let () = declaration := ((!declaration) @ [elpi_term; elpi_ty; elpi_tctx]) +[@@@end] + +open Elpi.API + +let in_ctx_for_term : ctx_for_term Conversion.ctx_readback = in_ctx_for_term + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !declaration + +let main () = + let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in + BuiltIn.document_file builtin; + exit 0 +;; + +main () diff --git a/ppx_elpi/tests/test_opaque_type.expected.ml b/ppx_elpi/tests/test_opaque_type.expected.ml index 1806fc2d6..624208a2a 100644 --- a/ppx_elpi/tests/test_opaque_type.expected.ml +++ b/ppx_elpi/tests/test_opaque_type.expected.ml @@ -1,6 +1,15 @@ let elpi_stuff = ref [] let pp_simple _ _ = () -type simple[@@deriving elpi { append = elpi_stuff }] +type simple[@@elpi.opaque + { + Elpi.API.OpaqueData.name = "simple"; + doc = ""; + pp = (fun fmt -> fun _ -> Format.fprintf fmt ""); + compare = Pervasives.compare; + hash = Hashtbl.hash; + hconsed = false; + constants = [] + }][@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -8,33 +17,75 @@ include let elpi_constant_type_simplec = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_simple - let (simple : simple Elpi.API.Conversion.t) = - Elpi.API.OpaqueData.declare + let elpi_opaque_data_decl_simple = + Elpi.API.RawOpaqueData.declare { Elpi.API.OpaqueData.name = "simple"; doc = ""; - pp = pp_simple; + pp = (fun fmt -> fun _ -> Format.fprintf fmt ""); compare = Pervasives.compare; hash = Hashtbl.hash; hconsed = false; constants = [] } - let elpi_embed_simple ~depth _ _ s t = - simple.Elpi.API.Conversion.embed ~depth s t - let elpi_readback_simple ~depth _ _ s t = - simple.Elpi.API.Conversion.readback ~depth s t + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end + let simple : + 'c . (simple, #Elpi.API.Conversion.ctx as 'c) Elpi.API.Conversion.t = + let name = "simple" in + let ({ Elpi.API.RawOpaqueData.cin = cin; isc; cout; name = c }, + constants_map, doc) + = elpi_opaque_data_decl_simple in + let ty = Elpi.API.Conversion.TyName name in + let embed ~depth:_ _ _ state x = + (state, (Elpi.API.RawData.mkCData (cin x)), []) in + let readback ~depth _ _ state t = + match Elpi.API.RawData.look ~depth t with + | Elpi.API.RawData.CData c when isc c -> (state, (cout c), []) + | Elpi.API.RawData.Const i when i < 0 -> + (try + (state, + (snd @@ + (Elpi.API.RawData.Constants.Map.find i constants_map)), + []) + with + | Not_found -> + raise (Elpi.API.Conversion.TypeErr (ty, depth, t))) + | _ -> raise (Elpi.API.Conversion.TypeErr (ty, depth, t)) in + let pp_doc fmt () = + if doc <> "" + then + (Elpi.API.PPX.Doc.comment fmt ("% " ^ doc); + Format.fprintf fmt "@\n"); + Format.fprintf fmt "@[typeabbrev %s (ctype \"%s\").@]@\n@\n" + name c; + Elpi.API.RawData.Constants.Map.iter + (fun _ -> + fun (c, _) -> + Format.fprintf fmt "@[type %s %s.@]@\n" c name) + constants_map in + { + Elpi.API.Conversion.embed = embed; + readback; + ty; + pp_doc; + pp = (fun fmt -> fun x -> Elpi.API.RawOpaqueData.pp fmt (cin x)) + } + let elpi_embed_simple = simple.Elpi.API.Conversion.embed + let elpi_readback_simple = simple.Elpi.API.Conversion.readback let elpi_simple = Elpi.API.BuiltIn.MLData simple - let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_simple] @ [])) + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API -[@@@warning "-26-27-32-39-60"] -let rec test : type h c. - depth:int -> - h -> - c -> - State.t -> - RawData.term -> (State.t * simple * Conversion.extra_goals) - = elpi_readback_simple +let test : 'h . (simple, #Conversion.ctx as 'h) Conversion.t = simple let builtin = let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) let main () = diff --git a/ppx_elpi/tests/test_opaque_type.ml b/ppx_elpi/tests/test_opaque_type.ml index ddc9b8783..f81f4f1a9 100644 --- a/ppx_elpi/tests/test_opaque_type.ml +++ b/ppx_elpi/tests/test_opaque_type.ml @@ -1,14 +1,12 @@ let elpi_stuff = ref [] let pp_simple _ _ = () -type simple -[@@deriving elpi { append = elpi_stuff }] +type simple [@@elpi.opaque {Elpi.API.OpaqueData.name = "simple"; doc = ""; pp = (fun fmt _ -> Format.fprintf fmt ""); compare = Pervasives.compare; hash = Hashtbl.hash; hconsed = false; constants = []; } ] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API -[@@@warning "-26-27-32-39-60"] -let rec test : type h c . depth:int -> h -> c -> State.t -> RawData.term -> State.t * simple * Conversion.extra_goals = - elpi_readback_simple +let test : 'h. (simple, #Conversion.ctx as 'h) Conversion.t = simple let builtin = let open BuiltIn in declare ~file_name:(Sys.argv.(1)) !elpi_stuff @@ -19,4 +17,4 @@ let main () = exit 0 ;; -main () \ No newline at end of file +main () diff --git a/ppx_elpi/tests/test_poly_adt.expected.elpi b/ppx_elpi/tests/test_poly_adt.expected.elpi index 1c1eacf0b..35a727166 100644 --- a/ppx_elpi/tests/test_poly_adt.expected.elpi +++ b/ppx_elpi/tests/test_poly_adt.expected.elpi @@ -6,13 +6,6 @@ type a simple A0. % A type b int -> simple A0. % B type c A0 -> int -> simple A0. % C -pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0. -map.simple F0 a a. -map.simple F0 (b A0) (b B0) :- ((=) A0 B0). -map.simple F0 (c A0 A1) (c B0 B1) :- (F0 A0 B0), ((=) A1 B1). - - - diff --git a/ppx_elpi/tests/test_poly_adt.expected.ml b/ppx_elpi/tests/test_poly_adt.expected.ml index d61cbab51..cea31a3d1 100644 --- a/ppx_elpi/tests/test_poly_adt.expected.ml +++ b/ppx_elpi/tests/test_poly_adt.expected.ml @@ -3,7 +3,7 @@ let pp_simple _ _ _ = () type 'a simple = | A | B of int - | C of 'a * int [@@deriving elpi { append = elpi_stuff }] + | C of 'a * int [@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -23,12 +23,13 @@ include let elpi_constant_constructor_simple_Cc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_simple_C + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding -> - ('elpi__param__a simple, 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + 'elpi__param__a 'c . + ('elpi__param__a, 'c) Elpi.API.Conversion.embedding -> + ('elpi__param__a simple, #Ctx_for_simple.t as 'c) + Elpi.API.Conversion.embedding = fun elpi_embed_elpi__param__a -> fun ~depth:elpi__depth -> @@ -62,11 +63,10 @@ include [elpi__14; elpi__15]), (List.concat [elpi__12; elpi__13])) let rec elpi_readback_simple : - 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback -> - ('elpi__param__a simple, 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + 'elpi__param__a 'c . + ('elpi__param__a, 'c) Elpi.API.Conversion.readback -> + ('elpi__param__a simple, #Ctx_for_simple.t as 'c) + Elpi.API.Conversion.readback = fun elpi_readback_elpi__param__a -> fun ~depth:elpi__depth -> @@ -115,18 +115,17 @@ include (Format.asprintf "Not a constructor of type %s: %a" "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) let simple : - 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t -> - ('elpi__param__a simple, 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + 'elpi__param__a 'c . + ('elpi__param__a, 'c) Elpi.API.Conversion.t -> + ('elpi__param__a simple, #Ctx_for_simple.t as 'c) + Elpi.API.Conversion.t = fun elpi__param__a -> let kind = - Elpi.API.ContextualConversion.TyApp - ("simple", (elpi__param__a.Elpi.API.ContextualConversion.ty), []) in + Elpi.API.Conversion.TyApp + ("simple", (elpi__param__a.Elpi.API.Conversion.ty), []) in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> @@ -135,51 +134,34 @@ include ~doc:"A" ~args:[]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"b" ~doc:"B" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty]); + ~args:[Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty]); Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"c" ~doc:"C" - ~args:[elpi__param__a.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty]); + ~args:[elpi__param__a.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty]); pp = (pp_simple elpi__param__a.pp); embed = - (elpi_embed_simple - elpi__param__a.Elpi.API.ContextualConversion.embed); + (elpi_embed_simple elpi__param__a.Elpi.API.Conversion.embed); readback = - (elpi_readback_simple - elpi__param__a.Elpi.API.ContextualConversion.readback) + (elpi_readback_simple elpi__param__a.Elpi.API.Conversion.readback) } let elpi_simple = - Elpi.API.BuiltIn.MLDataC - (simple - (Elpi.API.ContextualConversion.(!>) @@ - (Elpi.API.BuiltInData.poly "A0"))) - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0."; - "map.simple F0 a a."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "F0 " "b" "A0" "b" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "F0 " "c" "A0 A1" "c" "B0 B1" - (String.concat ", " - ["(" ^ - ("F0" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - "\n"])])) + Elpi.API.BuiltIn.MLData (simple (Elpi.API.BuiltInData.poly "A0")) + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] -let _ = - simple @@ (Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.int) -let _ = - simple @@ (Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.float) +class type o = + object inherit Elpi.API.Conversion.ctx method foobar : bool end +let (_ : (int simple, o) Elpi.API.Conversion.t) = + simple Elpi.API.BuiltInData.int +let (_ : (float simple, o) Elpi.API.Conversion.t) = + simple Elpi.API.BuiltInData.float open Elpi.API let builtin = let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) diff --git a/ppx_elpi/tests/test_poly_adt.ml b/ppx_elpi/tests/test_poly_adt.ml index 048fa01b3..ad3dfc5ac 100644 --- a/ppx_elpi/tests/test_poly_adt.ml +++ b/ppx_elpi/tests/test_poly_adt.ml @@ -2,10 +2,12 @@ let elpi_stuff = ref [] let pp_simple _ _ _ = () type 'a simple = A | B of int | C of 'a * int -[@@deriving elpi { append = elpi_stuff } ] +[@@deriving elpi { declaration = elpi_stuff } ] -let _ = simple @@ Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.int -let _ = simple @@ Elpi.API.ContextualConversion.(!>) Elpi.API.BuiltInData.float +class type o = object inherit Elpi.API.Conversion.ctx method foobar : bool end + +let _ : (int simple, o) Elpi.API.Conversion.t = simple Elpi.API.BuiltInData.int +let _ : (float simple, o) Elpi.API.Conversion.t = simple Elpi.API.BuiltInData.float open Elpi.API diff --git a/ppx_elpi/tests/test_poly_alias.expected.elpi b/ppx_elpi/tests/test_poly_alias.expected.elpi index 5bf826301..06136db4a 100644 --- a/ppx_elpi/tests/test_poly_alias.expected.elpi +++ b/ppx_elpi/tests/test_poly_alias.expected.elpi @@ -2,9 +2,6 @@ typeabbrev (simple A0) (pair A0 int). % simple -pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0. -map.simple F0 A B :- ((ppx.map.pair F0 (=)) A B). - diff --git a/ppx_elpi/tests/test_poly_alias.expected.ml b/ppx_elpi/tests/test_poly_alias.expected.ml index 95895145c..bd43e8a77 100644 --- a/ppx_elpi/tests/test_poly_alias.expected.ml +++ b/ppx_elpi/tests/test_poly_alias.expected.ml @@ -1,6 +1,6 @@ let elpi_stuff = ref [] let pp_simple _ _ _ = () -type 'a simple = ('a * int)[@@deriving elpi { append = elpi_stuff }] +type 'a simple = ('a * int)[@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -8,12 +8,13 @@ include let elpi_constant_type_simplec = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_simple + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding -> - ('elpi__param__a simple, 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + 'elpi__param__a 'c . + ('elpi__param__a, 'c) Elpi.API.Conversion.embedding -> + ('elpi__param__a simple, #Ctx_for_simple.t as 'c) + Elpi.API.Conversion.embedding = fun elpi_embed_elpi__param__a -> fun ~depth -> @@ -24,11 +25,10 @@ include (Elpi.Builtin.PPX.embed_pair elpi_embed_elpi__param__a Elpi.API.PPX.embed_int) ~depth h c s t let rec elpi_readback_simple : - 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback -> - ('elpi__param__a simple, 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + 'elpi__param__a 'c . + ('elpi__param__a, 'c) Elpi.API.Conversion.readback -> + ('elpi__param__a simple, #Ctx_for_simple.t as 'c) + Elpi.API.Conversion.readback = fun elpi_readback_elpi__param__a -> fun ~depth -> @@ -40,56 +40,48 @@ include elpi_readback_elpi__param__a Elpi.API.PPX.readback_int) ~depth h c s t let simple : - 'elpi__param__a 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ('elpi__param__a, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t -> - ('elpi__param__a simple, 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + 'elpi__param__a 'c . + ('elpi__param__a, 'c) Elpi.API.Conversion.t -> + ('elpi__param__a simple, #Ctx_for_simple.t as 'c) + Elpi.API.Conversion.t = fun elpi__param__a -> let kind = - Elpi.API.ContextualConversion.TyApp - ("simple", (elpi__param__a.Elpi.API.ContextualConversion.ty), []) in + Elpi.API.Conversion.TyApp + ("simple", (elpi__param__a.Elpi.API.Conversion.ty), []) in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; ()); pp = (pp_simple elpi__param__a.pp); embed = - (elpi_embed_simple - elpi__param__a.Elpi.API.ContextualConversion.embed); + (elpi_embed_simple elpi__param__a.Elpi.API.Conversion.embed); readback = - (elpi_readback_simple - elpi__param__a.Elpi.API.ContextualConversion.readback) + (elpi_readback_simple elpi__param__a.Elpi.API.Conversion.readback) } let elpi_simple = - let elpi__param__a = - Elpi.API.ContextualConversion.(!>) @@ - (Elpi.API.BuiltInData.poly (Printf.sprintf "A%d" 0)) in + let elpi__param__a = Elpi.API.BuiltInData.poly (Printf.sprintf "A%d" 0) in Elpi.API.BuiltIn.LPCode ("typeabbrev " ^ (("(" ^ ("simple" ^ (" " ^ ("A0" ^ ")")))) ^ (" " ^ (((Elpi.API.PPX.Doc.show_ty_ast ~outer:false) @@ - (Elpi.API.ContextualConversion.(!>>>) Elpi.Builtin.pair - elpi__param__a - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int)).Elpi.API.ContextualConversion.ty) + (Elpi.Builtin.pair elpi__param__a + Elpi.API.BuiltInData.int).Elpi.API.Conversion.ty) ^ (". % " ^ "simple"))))) - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:(X0 -> Y0 -> prop), i:simple X0, o:simple Y0."; - Printf.sprintf "map.%s %sA B :- %s." "simple" "F0 " - ("(" ^ - ((Printf.sprintf "(ppx.map.pair %s %s)" "F0" "(=)") - ^ (" " ^ ("A" ^ (" " ^ ("B" ^ ")"))))))])])) + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API +let x : 'c . ('a, 'c) Conversion.t -> ('a simple, 'c) Conversion.t = simple let builtin = let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) let main () = diff --git a/ppx_elpi/tests/test_poly_alias.ml b/ppx_elpi/tests/test_poly_alias.ml index 36c5bb745..f539a0d7c 100644 --- a/ppx_elpi/tests/test_poly_alias.ml +++ b/ppx_elpi/tests/test_poly_alias.ml @@ -2,10 +2,12 @@ let elpi_stuff = ref [] let pp_simple _ _ _ = () type 'a simple = 'a * int -[@@deriving elpi { append = elpi_stuff }] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API +let x : 'c. ('a, 'c) Conversion.t -> ('a simple, 'c)Conversion.t = simple + let builtin = let open BuiltIn in declare ~file_name:(Sys.argv.(1)) !elpi_stuff @@ -15,4 +17,4 @@ let main () = exit 0 ;; -main () \ No newline at end of file +main () diff --git a/ppx_elpi/tests/test_simple_adt.expected.elpi b/ppx_elpi/tests/test_simple_adt.expected.elpi index 4372d70a1..e188187fb 100644 --- a/ppx_elpi/tests/test_simple_adt.expected.elpi +++ b/ppx_elpi/tests/test_simple_adt.expected.elpi @@ -5,12 +5,6 @@ kind simple type. type a simple. % A type b int -> simple. % B -pred map.simple i:simple, o:simple. -map.simple a a. -map.simple (b A0) (b B0) :- ((=) A0 B0). - - - diff --git a/ppx_elpi/tests/test_simple_adt.expected.ml b/ppx_elpi/tests/test_simple_adt.expected.ml index a934f7724..195f925b5 100644 --- a/ppx_elpi/tests/test_simple_adt.expected.ml +++ b/ppx_elpi/tests/test_simple_adt.expected.ml @@ -2,7 +2,7 @@ let elpi_stuff = ref [] let pp_simple _ _ = () type simple = | A - | B of int [@@deriving elpi { append = elpi_stuff }] + | B of int [@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -18,11 +18,10 @@ include let elpi_constant_constructor_simple_Bc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_simple_B + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -42,10 +41,7 @@ include elpi_constant_constructor_simple_Bc [elpi__5]), (List.concat [elpi__4])) let rec elpi_readback_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -72,14 +68,11 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t + let simple : 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "simple" in + let kind = Elpi.API.Conversion.TyName "simple" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> @@ -87,27 +80,21 @@ include Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"a" ~doc:"A" ~args:[]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"b" ~doc:"B" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty]); + ~args:[Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty]); pp = pp_simple; embed = elpi_embed_simple; readback = elpi_readback_simple } - let elpi_simple = Elpi.API.BuiltIn.MLDataC simple - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:simple, o:simple."; - "map.simple a a."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "" "b" "A0" "b" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - "\n"])])) + let elpi_simple = Elpi.API.BuiltIn.MLData simple + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API let builtin = diff --git a/ppx_elpi/tests/test_simple_adt.ml b/ppx_elpi/tests/test_simple_adt.ml index 94be901bb..e8d74e639 100644 --- a/ppx_elpi/tests/test_simple_adt.ml +++ b/ppx_elpi/tests/test_simple_adt.ml @@ -2,7 +2,7 @@ let elpi_stuff = ref [] let pp_simple _ _ = () type simple = A | B of int -[@@deriving elpi { append = elpi_stuff }] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API diff --git a/ppx_elpi/tests/test_simple_adt_record.expected.elpi b/ppx_elpi/tests/test_simple_adt_record.expected.elpi index 06a020926..bd46ad6ad 100644 --- a/ppx_elpi/tests/test_simple_adt_record.expected.elpi +++ b/ppx_elpi/tests/test_simple_adt_record.expected.elpi @@ -5,12 +5,6 @@ kind simple type. type k1 int -> bool -> simple. % K1 type k2 bool -> simple. % K2 -pred map.simple i:simple, o:simple. -map.simple (k1 A0 A1) (k1 B0 B1) :- ((=) A0 B0), ((=) A1 B1). -map.simple (k2 A0) (k2 B0) :- ((=) A0 B0). - - - diff --git a/ppx_elpi/tests/test_simple_adt_record.expected.ml b/ppx_elpi/tests/test_simple_adt_record.expected.ml index c2a275f6f..7eacccf6f 100644 --- a/ppx_elpi/tests/test_simple_adt_record.expected.ml +++ b/ppx_elpi/tests/test_simple_adt_record.expected.ml @@ -5,7 +5,7 @@ type simple = f: int ; g: bool } | K2 of { - f2: bool } [@@deriving elpi { append = elpi_stuff }] + f2: bool } [@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -21,11 +21,10 @@ include let elpi_constant_constructor_simple_K2c = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_simple_K2 + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -52,10 +51,7 @@ include elpi_constant_constructor_simple_K2c [elpi__15]), (List.concat [elpi__14])) let rec elpi_readback_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -97,49 +93,34 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t + let simple : 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "simple" in + let kind = Elpi.API.Conversion.TyName "simple" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"k1" ~doc:"K1" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]; + ~args:[Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"k2" ~doc:"K2" - ~args:[(Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + ~args:[Elpi.Builtin.bool.Elpi.API.Conversion.ty]); pp = pp_simple; embed = elpi_embed_simple; readback = elpi_readback_simple } - let elpi_simple = Elpi.API.BuiltIn.MLDataC simple - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:simple, o:simple."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "" "k1" "A0 A1" "k1" "B0 B1" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "" "k2" "A0" "k2" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - "\n"])])) + let elpi_simple = Elpi.API.BuiltIn.MLData simple + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API let builtin = diff --git a/ppx_elpi/tests/test_simple_adt_record.ml b/ppx_elpi/tests/test_simple_adt_record.ml index dc8b91bb4..adf90b660 100644 --- a/ppx_elpi/tests/test_simple_adt_record.ml +++ b/ppx_elpi/tests/test_simple_adt_record.ml @@ -2,7 +2,7 @@ let elpi_stuff = ref [] let pp_simple _ _ = () type simple = K1 of { f : int; g : bool } | K2 of { f2 : bool } -[@@deriving elpi { append = elpi_stuff }] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API @@ -15,4 +15,4 @@ let main () = exit 0 ;; -main () \ No newline at end of file +main () diff --git a/ppx_elpi/tests/test_simple_contextual.expected.elpi b/ppx_elpi/tests/test_simple_contextual.expected.elpi index 6007bbcd6..0822d5efd 100644 --- a/ppx_elpi/tests/test_simple_contextual.expected.elpi +++ b/ppx_elpi/tests/test_simple_contextual.expected.elpi @@ -1,7 +1,7 @@ -% ctx -kind ctx type. +% tctx +kind tctx type. type entry nominal -> string -> bool -> prop. % Entry % term @@ -9,13 +9,6 @@ kind term type. type app term -> term -> term. % App type lam bool -> string -> (term -> term) -> term. % Lam -pred map.term i:term, o:term. -map.term (var A0) (var B0) :- ((=) A0 B0). -map.term (app A0 A1) (app B0 B1) :- (map.term A0 B0), (map.term A1 B1). -map.term (lam A0 A1 A2) (lam B0 B1 B2) :- ((=) A0 B0), ((=) A1 B1), (pi x fixme x => (=) A2 B2). - - - diff --git a/ppx_elpi/tests/test_simple_contextual.expected.ml b/ppx_elpi/tests/test_simple_contextual.expected.ml index 0c397e927..e19db3caf 100644 --- a/ppx_elpi/tests/test_simple_contextual.expected.ml +++ b/ppx_elpi/tests/test_simple_contextual.expected.ml @@ -1,44 +1,42 @@ -let elpi_stuff = ref [] +let declaration = ref [] module String = struct include String let pp fmt s = Format.fprintf fmt "%s" s let show = Format.asprintf "%a" pp end -let pp_ctx _ _ = () -type ctx = - | Entry of ((string)[@elpi.key ]) * bool [@@deriving - elpi - { - append = elpi_stuff; - index = (module String) - }] +let pp_tctx _ _ = () +type tctx = + | Entry of ((string)[@elpi.key ]) * bool [@@elpi.index (module String)] +[@@deriving elpi { declaration }] include struct [@@@warning "-26-27-32-39-60"] - let elpi_constant_type_ctx = "ctx" - let elpi_constant_type_ctxc = - Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_type_ctx - let elpi_constant_constructor_ctx_Entry = "entry" - let elpi_constant_constructor_ctx_Entryc = + let elpi_constant_type_tctx = "tctx" + let elpi_constant_type_tctxc = Elpi.API.RawData.Constants.declare_global_symbol - elpi_constant_constructor_ctx_Entry - module Elpi_ctx_Map = (Elpi.API.Utils.Map.Make)(String) - let elpi_ctx_state = - Elpi.API.State.declare ~name:"ctx" + elpi_constant_type_tctx + let elpi_constant_constructor_tctx_Entry = "entry" + let elpi_constant_constructor_tctx_Entryc = + Elpi.API.RawData.Constants.declare_global_symbol + elpi_constant_constructor_tctx_Entry + module Elpi_tctx_Map = (Elpi.API.Utils.Map.Make)(String) + let elpi_tctx_state = + Elpi.API.State.declare ~name:"tctx" ~pp:(fun fmt -> fun _ -> Format.fprintf fmt "TODO") ~init:(fun () -> - ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant - Elpi_ctx_Map.t), - (Elpi.API.RawData.Constants.Map.empty : ctx - Elpi.API.ContextualConversion.ctx_entry + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.Conversion.ctx_entry Elpi.API.RawData.Constants.Map.t))) - let elpi_ctx_to_key ~depth:_ = function | Entry (elpi__1, _) -> elpi__1 - let elpi_is_ctx ~depth:elpi__depth elpi__x = + let elpi_tctx_to_key ~depth:_ = + function | Entry (elpi__16, _) -> elpi__16 + let elpi_is_tctx { Elpi.API.Data.hdepth = elpi__depth; hsrc = elpi__x } = match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const _ -> None | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> - if false || (elpi__hd == elpi_constant_constructor_ctx_Entryc) + if false || (elpi__hd == elpi_constant_constructor_tctx_Entryc) then (match Elpi.API.RawData.look ~depth:elpi__depth elpi__idx with | Elpi.API.RawData.Const x -> Some x @@ -47,59 +45,62 @@ include "context entry applied to a non nominal") else None | _ -> None - let elpi_push_ctx ~depth:elpi__depth elpi__state elpi__name + let elpi_push_tctx ~depth:elpi__depth elpi__state elpi__name elpi__ctx_item = let (elpi__ctx2dbl, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in let elpi__i = elpi__depth in - let elpi__ctx2dbl = Elpi_ctx_Map.add elpi__name elpi__i elpi__ctx2dbl in + let elpi__ctx2dbl = Elpi_tctx_Map.add elpi__name elpi__i elpi__ctx2dbl in let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.add elpi__i elpi__ctx_item elpi__dbl2ctx in let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state + Elpi.API.State.set elpi_tctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state - let elpi_pop_ctx ~depth:elpi__depth elpi__state elpi__name = + let elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__name = let (elpi__ctx2dbl, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in let elpi__i = elpi__depth in - let elpi__ctx2dbl = Elpi_ctx_Map.remove elpi__name elpi__ctx2dbl in + let elpi__ctx2dbl = Elpi_tctx_Map.remove elpi__name elpi__ctx2dbl in let elpi__dbl2ctx = Elpi.API.RawData.Constants.Map.remove elpi__i elpi__dbl2ctx in let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state + Elpi.API.State.set elpi_tctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state - let rec elpi_embed_ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + module Ctx_for_tctx = + struct class type t = object inherit Elpi.API.Conversion.ctx end end + let rec elpi_embed_tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> fun elpi__state -> function - | (elpi__10, Entry (elpi__8, elpi__9)) -> + | (elpi__9, Entry (elpi__7, elpi__8)) -> + let (elpi__state, elpi__13, elpi__10) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__9 in let (elpi__state, elpi__14, elpi__11) = - Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__10 in - let (elpi__state, elpi__15, elpi__12) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__8 in - let (elpi__state, elpi__16, elpi__13) = + elpi__constraints elpi__state elpi__7 in + let (elpi__state, elpi__15, elpi__12) = Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__9 in + elpi__constraints elpi__state elpi__8 in (elpi__state, (Elpi.API.RawData.mkAppL - elpi_constant_constructor_ctx_Entryc - [elpi__14; elpi__15; elpi__16]), - (List.concat [elpi__11; elpi__12; elpi__13])) - let rec elpi_readback_ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + elpi_constant_constructor_tctx_Entryc + [elpi__13; elpi__14; elpi__15]), + (List.concat [elpi__10; elpi__11; elpi__12])) + let rec elpi_readback_tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> @@ -108,120 +109,93 @@ include fun elpi__x -> match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when - elpi__hd == elpi_constant_constructor_ctx_Entryc -> - let (elpi__state, elpi__7, elpi__6) = - Elpi.API.PPX.readback_nominal ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__x in + elpi__hd == elpi_constant_constructor_tctx_Entryc -> + let (elpi__state, elpi__6, elpi__5) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in (match elpi__xs with - | elpi__2::elpi__3::[] -> - let (elpi__state, elpi__2, elpi__4) = + | elpi__1::elpi__2::[] -> + let (elpi__state, elpi__1, elpi__3) = Elpi.API.PPX.readback_string ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__2 in - let (elpi__state, elpi__3, elpi__5) = + elpi__hyps elpi__constraints elpi__state elpi__1 in + let (elpi__state, elpi__2, elpi__4) = Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__3 in - (elpi__state, (elpi__7, (Entry (elpi__2, elpi__3))), - (List.concat [elpi__6; elpi__4; elpi__5])) + elpi__hyps elpi__constraints elpi__state elpi__2 in + (elpi__state, (elpi__6, (Entry (elpi__1, elpi__2))), + (List.concat [elpi__5; elpi__3; elpi__4])) | _ -> Elpi.API.Utils.type_error ("Not enough arguments to constructor: " ^ (Elpi.API.RawData.Constants.show - elpi_constant_constructor_ctx_Entryc))) + elpi_constant_constructor_tctx_Entryc))) | _ -> Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" - "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + "tctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) + let tctx : + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "ctx" in + let kind = Elpi.API.Conversion.TyName "tctx" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> - Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; + Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; Elpi.API.PPX.Doc.constructor fmt - ~ty:(Elpi.API.ContextualConversion.TyName "prop") - ~name:"entry" ~doc:"Entry" - ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); - pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); - embed = elpi_embed_ctx; - readback = elpi_readback_ctx + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"entry" + ~doc:"Entry" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]); + pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); + embed = elpi_embed_tctx; + readback = elpi_readback_tctx } - let in_ctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state = - let module CMap = Elpi.API.RawData.Constants.Map in - let elpi__filtered_hyps = - List.fold_left - (fun elpi__m -> - fun - ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as - elpi__hyp) - -> - match elpi_is_ctx ~depth:elpi__i elpi__hsrc with - | None -> elpi__m - | Some elpi__idx -> - (if CMap.mem elpi__idx elpi__m - then - Elpi.API.Utils.type_error - "more than one context entry for the same nominal"; - CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty - (Elpi.API.RawData.of_hyps elpi__hyps) in - let rec elpi__aux elpi__state elpi__gls elpi__i = - if elpi__i = elpi__depth - then (elpi__state, (List.concat (List.rev elpi__gls))) - else - if not (CMap.mem elpi__i elpi__filtered_hyps) - then elpi__aux elpi__state elpi__gls (elpi__i + 1) - else - (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in - let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in - let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = - ctx.Elpi.API.ContextualConversion.readback - ~depth:elpi__hyp_depth elpi__hyps elpi__constraints - elpi__state elpi__hyp.Elpi.API.RawData.hsrc in - assert (elpi__nominal = elpi__i); - (let elpi__s = elpi_ctx_to_key ~depth:elpi__hyp_depth elpi__t in - let elpi__state = - elpi_push_ctx ~depth:elpi__i elpi__state elpi__s - { - Elpi.API.ContextualConversion.entry = elpi__t; - depth = elpi__hyp_depth - } in - elpi__aux elpi__state (elpi__gls_t :: elpi__gls) - (elpi__i + 1))) in - let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state - (Elpi_ctx_Map.empty, CMap.empty) in - let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in - let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in - (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) - let in_ctx = in_ctx_alone - let elpi_ctx = Elpi.API.BuiltIn.MLDataC ctx - let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_ctx] @ [])) + let context_made_of_tctx = + { + Elpi.API.Conversion.is_entry_for_nominal = elpi_is_tctx; + to_key = elpi_tctx_to_key; + push = elpi_push_tctx; + pop = elpi_pop_tctx; + conv = tctx; + init = + (fun state -> + Elpi.API.State.set elpi_tctx_state state + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.Conversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))); + get = + (fun state -> snd @@ (Elpi.API.State.get elpi_tctx_state state)) + } + let elpi_tctx = Elpi.API.BuiltIn.MLData tctx + class ctx_for_tctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tctx.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_tctx : Ctx_for_tctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_tctx) h s), (List.concat [])) + let () = declaration := ((!declaration) @ [elpi_tctx]) end[@@ocaml.doc "@inline"][@@merlin.hide ] +let tctx : 'c . ((int * tctx), 'c) Elpi.API.Conversion.t = tctx +let context_made_of_tctx : + 'c . (tctx, string, #ctx_for_tctx as 'c) Elpi.API.Conversion.context = + context_made_of_tctx +let in_ctx_for_tctx : ctx_for_tctx Elpi.API.Conversion.ctx_readback = + in_ctx_for_tctx let pp_term _ _ = () type term = - | Var of string [@elpi.var ] + | Var of string [@elpi.var tctx] | App of term * term | Lam of bool * string * - ((term)[@elpi.binder fun b -> fun s -> Entry (s, b)]) [@@deriving - elpi - { - append = - elpi_stuff; - context = - (() : - term -> - ctx) - }] + ((term)[@elpi.binder "term" tctx (fun b -> fun s -> Entry (s, b))]) +[@@deriving elpi { declaration }] include struct [@@@warning "-26-27-32-39-60"] @@ -241,11 +215,17 @@ include let elpi_constant_constructor_term_Lamc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_term_Lam + module Ctx_for_term = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -253,13 +233,13 @@ include function | Var elpi__29 -> let (elpi__ctx2dbl, _) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in let elpi__key = (fun x -> x) elpi__29 in - (if not (Elpi_ctx_Map.mem elpi__key elpi__ctx2dbl) + (if not (Elpi_tctx_Map.mem elpi__key elpi__ctx2dbl) then Elpi.API.Utils.error "Unbound variable"; (elpi__state, (Elpi.API.RawData.mkBound - (Elpi_ctx_Map.find elpi__key elpi__ctx2dbl)), [])) + (Elpi_tctx_Map.find elpi__key elpi__ctx2dbl)), [])) | App (elpi__32, elpi__33) -> let (elpi__state, elpi__36, elpi__34) = elpi_embed_term ~depth:elpi__depth elpi__hyps @@ -282,21 +262,21 @@ include let elpi__ctx_entry = (fun b -> fun s -> Entry (s, b)) elpi__38 elpi__39 in let elpi__ctx_key = - elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = - elpi_push_ctx ~depth:(elpi__depth + 1) elpi__state + elpi_push_tctx ~depth:(elpi__depth + 1) elpi__state elpi__ctx_key elpi__ctx_entry in let (elpi__state, elpi__47, elpi__43) = elpi_embed_term ~depth:(elpi__depth + 1) elpi__hyps elpi__constraints elpi__state elpi__40 in let elpi__46 = Elpi.API.RawData.mkLam elpi__47 in let elpi__state = - elpi_pop_ctx ~depth:(elpi__depth + 1) elpi__state + elpi_pop_tctx ~depth:(elpi__depth + 1) elpi__state elpi__ctx_key in (elpi__state, (Elpi.API.RawData.mkAppL @@ -304,10 +284,7 @@ include [elpi__44; elpi__45; elpi__46]), (List.concat [elpi__41; elpi__42; elpi__43])) let rec elpi_readback_term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -316,7 +293,7 @@ include match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const elpi__hd when elpi__hd >= 0 -> let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in + Elpi.API.State.get elpi_tctx_state elpi__state in (if not (Elpi.API.RawData.Constants.Map.mem elpi__hd @@ -326,16 +303,16 @@ include (Format.asprintf "Unbound variable: %s in %a" (Elpi.API.RawData.Constants.show elpi__hd) (Elpi.API.RawData.Constants.Map.pp - (Elpi.API.ContextualConversion.pp_ctx_entry - pp_ctx)) elpi__dbl2ctx); - (let { - Elpi.API.ContextualConversion.entry = elpi__entry; + (Elpi.API.Conversion.pp_ctx_entry pp_tctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd elpi__dbl2ctx in (elpi__state, - (Var (elpi_ctx_to_key ~depth:elpi__depth elpi__entry)), + (Var + (elpi_tctx_to_key ~depth:elpi__depth elpi__entry)), []))) | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_term_Appc -> @@ -368,15 +345,15 @@ include let elpi__ctx_entry = (fun b -> fun s -> Entry (s, b)) elpi__28 elpi__23 in let elpi__ctx_key = - elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in + elpi_tctx_to_key ~depth:elpi__depth + elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = - elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = - elpi_push_ctx ~depth:elpi__depth elpi__state + elpi_push_tctx ~depth:elpi__depth elpi__state elpi__ctx_key elpi__ctx_entry in let (elpi__state, elpi__24, elpi__26) = match Elpi.API.RawData.look ~depth:elpi__depth @@ -388,7 +365,7 @@ include elpi__bo | _ -> assert false in let elpi__state = - elpi_pop_ctx ~depth:elpi__depth elpi__state + elpi_pop_tctx ~depth:elpi__depth elpi__state elpi__ctx_key in (elpi__state, (Lam (elpi__28, elpi__23, elpi__24)), (List.concat [elpi__27; elpi__25; elpi__26])) @@ -401,75 +378,82 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "term" in + let term : 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "term" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"app" ~doc:"App" - ~args:[Elpi.API.ContextualConversion.TyName - elpi_constant_type_term; - Elpi.API.ContextualConversion.TyName - elpi_constant_type_term]; + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_term; + Elpi.API.Conversion.TyName elpi_constant_type_term]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" ~doc:"Lam" - ~args:[(Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyApp - ("->", - (Elpi.API.ContextualConversion.TyName "term"), - [Elpi.API.ContextualConversion.TyName + ~args:[Elpi.Builtin.bool.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "term"), + [Elpi.API.Conversion.TyName elpi_constant_type_term])]); pp = pp_term; embed = elpi_embed_term; readback = elpi_readback_term } - let elpi_term = Elpi.API.BuiltIn.MLDataC term - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_term] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.term i:term, o:term."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" - "" "var" "A0" "var" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" - "" "app" "A0 A1" "app" "B0 B1" - (String.concat ", " - ["(" ^ - (("map." ^ elpi_constant_type_term) ^ - (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - (("map." ^ elpi_constant_type_term) ^ - (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "term" - "" "lam" "A0 A1 A2" "lam" "B0 B1 B2" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")"))))); - Printf.sprintf "(pi x fixme x => (=) %s %s)" "A2" - "B2"]); - "\n"])])) + let elpi_term = Elpi.API.BuiltIn.MLData term + class ctx_for_term (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_term.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_term : Ctx_for_term.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx + h c s in + (s, ((new ctx_for_term) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_term]) end[@@ocaml.doc "@inline"][@@merlin.hide ] +let term : 'c . (term, #ctx_for_term as 'c) Elpi.API.Conversion.t = term +let in_ctx_for_term : ctx_for_term Elpi.API.Conversion.ctx_readback = + in_ctx_for_term open Elpi.API -let builtin = - let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!elpi_stuff) +open BuiltInPredicate +open Notation +let term_to_string = + Pred + ("term->string", + (In (term, "T", (Out (BuiltInData.string, "S", (Read "what else"))))), + in_ctx_for_term, + (fun (t : term) -> + fun (_ety : string oarg) -> + fun ~depth:_ -> + fun c -> + fun (_cst : Data.constraints) -> + fun (_state : State.t) -> + !: + (Format.asprintf "@[%a@ |-@ %a@]@\n%!" + (RawData.Constants.Map.pp + (Conversion.pp_ctx_entry pp_tctx)) c#tctx + term.pp t))) +let builtin1 = + let open BuiltIn in + declare ~file_name:"test_ppx.elpi" + ((!declaration) @ + ([MLCode (term_to_string, DocAbove); + LPDoc "----------------- elpi ----------------"] @ + (let open Elpi.Builtin in core_builtins @ elpi_builtins))) +let builtin2 = + let open BuiltIn in declare ~file_name:(Sys.argv.(1)) (!declaration) let main () = - let (_elpi, _) = Setup.init ~builtins:[builtin] ~basedir:"." [] in - BuiltIn.document_file builtin; exit 0 + let (_elpi, _) = Setup.init ~builtins:[builtin1; builtin2] ~basedir:"." [] in + BuiltIn.document_file builtin2; exit 0 ;;main () diff --git a/ppx_elpi/tests/test_simple_contextual.ml b/ppx_elpi/tests/test_simple_contextual.ml index 508f8d587..34e5f5658 100644 --- a/ppx_elpi/tests/test_simple_contextual.ml +++ b/ppx_elpi/tests/test_simple_contextual.ml @@ -1,4 +1,4 @@ -let elpi_stuff = ref [] +let declaration = ref [] module String = struct include String @@ -6,26 +6,54 @@ module String = struct let show = Format.asprintf "%a" pp end -let pp_ctx _ _ = () -type ctx = Entry of (string[@elpi.key]) * bool -[@@deriving elpi { append = elpi_stuff; index = (module String) }] +let pp_tctx _ _ = () +type tctx = Entry of (string[@elpi.key]) * bool + [@@elpi.index (module String)] +[@@deriving elpi { declaration }] + +let tctx : 'c. (int * tctx, 'c) Elpi.API.Conversion.t = tctx +let context_made_of_tctx : 'c. (tctx, string, #ctx_for_tctx as 'c) Elpi.API.Conversion.context = context_made_of_tctx +let in_ctx_for_tctx : ctx_for_tctx Elpi.API.Conversion.ctx_readback = in_ctx_for_tctx let pp_term _ _ = () type term = - | Var of string [@elpi.var] + | Var of string [@elpi.var tctx] | App of term * term - | Lam of bool * string * (term[@elpi.binder (fun b s -> Entry(s,b))]) -[@@deriving elpi { append = elpi_stuff; context = (() : term -> ctx) }] + | Lam of bool * string * (term[@elpi.binder "term" tctx (fun b s -> Entry(s,b))]) +[@@deriving elpi { declaration }] + +let term : 'c. (term, #ctx_for_term as 'c) Elpi.API.Conversion.t = term +let in_ctx_for_term : ctx_for_term Elpi.API.Conversion.ctx_readback = in_ctx_for_term open Elpi.API +open BuiltInPredicate +open Notation + +let term_to_string = Pred("term->string", + In(term,"T", + Out(BuiltInData.string,"S", + Read("what else"))),in_ctx_for_term, + fun (t : term) (_ety : string oarg) + ~depth:_ c (_cst : Data.constraints) (_state : State.t) -> + + !: (Format.asprintf "@[%a@ |-@ %a@]@\n%!" + (RawData.Constants.Map.pp (Conversion.pp_ctx_entry pp_tctx)) c#tctx + term.pp t) -let builtin = let open BuiltIn in - declare ~file_name:(Sys.argv.(1)) !elpi_stuff +) + +let builtin1 = let open BuiltIn in + declare ~file_name:"test_ppx.elpi" (!declaration @ [ + MLCode(term_to_string,DocAbove); + LPDoc "----------------- elpi ----------------" + ] @ Elpi.Builtin.(core_builtins @ elpi_builtins)) + +let builtin2 = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) !declaration let main () = - let _elpi, _ = Setup.init ~builtins:[builtin] ~basedir:"." [] in - BuiltIn.document_file builtin; + let _elpi, _ = Setup.init ~builtins:[builtin1;builtin2] ~basedir:"." [] in + BuiltIn.document_file builtin2; exit 0 ;; - -main () \ No newline at end of file +main () diff --git a/ppx_elpi/tests/test_simple_record.expected.elpi b/ppx_elpi/tests/test_simple_record.expected.elpi index a8ab141dc..1f2783c04 100644 --- a/ppx_elpi/tests/test_simple_record.expected.elpi +++ b/ppx_elpi/tests/test_simple_record.expected.elpi @@ -4,11 +4,6 @@ kind simple type. type simple int -> bool -> simple. % simple -pred map.simple i:simple, o:simple. -map.simple (simple A0 A1) (simple B0 B1) :- ((=) A0 B0), ((=) A1 B1). - - - diff --git a/ppx_elpi/tests/test_simple_record.expected.ml b/ppx_elpi/tests/test_simple_record.expected.ml index 4baa031c5..70e54fc76 100644 --- a/ppx_elpi/tests/test_simple_record.expected.ml +++ b/ppx_elpi/tests/test_simple_record.expected.ml @@ -2,7 +2,7 @@ let elpi_stuff = ref [] let pp_simple _ _ = () type simple = { f: int ; - g: bool }[@@deriving elpi { append = elpi_stuff }] + g: bool }[@@deriving elpi { declaration = elpi_stuff }] include struct [@@@warning "-26-27-32-39-60"] @@ -14,11 +14,10 @@ include let elpi_constant_constructor_simple_simplec = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_simple_simple + module Ctx_for_simple = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -37,10 +36,7 @@ include [elpi__9; elpi__10]), (List.concat [elpi__7; elpi__8])) let rec elpi_readback_simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -68,43 +64,33 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "simple" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let simple : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (simple, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t + let simple : 'c . (simple, #Ctx_for_simple.t as 'c) Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "simple" in + let kind = Elpi.API.Conversion.TyName "simple" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"simple"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"simple" ~doc:"simple" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.int).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + ~args:[Elpi.API.BuiltInData.int.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]); pp = pp_simple; embed = elpi_embed_simple; readback = elpi_readback_simple } - let elpi_simple = Elpi.API.BuiltIn.MLDataC simple - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_simple] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.simple i:simple, o:simple."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "simple" - "" "simple" "A0 A1" "simple" "B0 B1" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - ("(=)" ^ (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - "\n"])])) + let elpi_simple = Elpi.API.BuiltIn.MLData simple + class ctx_for_simple (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_simple.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_simple : + Ctx_for_simple.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_simple) h s), (List.concat [])) + let () = elpi_stuff := ((!elpi_stuff) @ [elpi_simple]) end[@@ocaml.doc "@inline"][@@merlin.hide ] open Elpi.API let builtin = diff --git a/ppx_elpi/tests/test_simple_record.ml b/ppx_elpi/tests/test_simple_record.ml index f3f009246..0c84d82f4 100644 --- a/ppx_elpi/tests/test_simple_record.ml +++ b/ppx_elpi/tests/test_simple_record.ml @@ -2,7 +2,7 @@ let elpi_stuff = ref [] let pp_simple _ _ = () type simple = { f : int; g : bool } -[@@deriving elpi { append = elpi_stuff }] +[@@deriving elpi { declaration = elpi_stuff }] open Elpi.API diff --git a/ppx_elpi/tests/test_two_layers_context.expected.elpi b/ppx_elpi/tests/test_two_layers_context.expected.elpi index 99e20ca84..ad11a34c2 100644 --- a/ppx_elpi/tests/test_two_layers_context.expected.elpi +++ b/ppx_elpi/tests/test_two_layers_context.expected.elpi @@ -1,5 +1,5 @@ -{{ c4 -> { Data.ContextualConversion.entry = ; depth = 5 }; }} -{{ c0 -> { Data.ContextualConversion.entry = ; depth = 5 }; c2 -> - { Data.ContextualConversion.entry = ; depth = 5 }; }} |- App f arg +{{ c4 -> { Data.Conversion.entry = ; depth = 5 }; }} +{{ c0 -> { Data.Conversion.entry = ; depth = 5 }; c2 -> + { Data.Conversion.entry = ; depth = 5 }; }} |- App f arg Lam zzzz (zzzz) diff --git a/ppx_elpi/tests/test_two_layers_context.expected.ml b/ppx_elpi/tests/test_two_layers_context.expected.ml index da94e4b65..d485a59dd 100644 --- a/ppx_elpi/tests/test_two_layers_context.expected.ml +++ b/ppx_elpi/tests/test_two_layers_context.expected.ml @@ -1,4 +1,4 @@ -let elpi_stuff = ref [] +let declaration = ref [] module String = struct include String @@ -7,12 +7,8 @@ module String = end let pp_tctx _ _ = () type tctx = - | TDecl of ((string)[@elpi.key ]) * bool [@@deriving - elpi - { - index = (module String); - append = elpi_stuff - }] + | TDecl of ((string)[@elpi.key ]) * bool [@@elpi.index (module String)] +[@@deriving elpi { declaration }] include struct [@@@warning "-26-27-32-39-60"] @@ -32,10 +28,11 @@ include ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant Elpi_tctx_Map.t), (Elpi.API.RawData.Constants.Map.empty : tctx - Elpi.API.ContextualConversion.ctx_entry + Elpi.API.Conversion.ctx_entry Elpi.API.RawData.Constants.Map.t))) - let elpi_tctx_to_key ~depth:_ = function | TDecl (elpi__1, _) -> elpi__1 - let elpi_is_tctx ~depth:elpi__depth elpi__x = + let elpi_tctx_to_key ~depth:_ = + function | TDecl (elpi__16, _) -> elpi__16 + let elpi_is_tctx { Elpi.API.Data.hdepth = elpi__depth; hsrc = elpi__x } = match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const _ -> None | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> @@ -72,35 +69,38 @@ include Elpi.API.State.set elpi_tctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state + module Ctx_for_tctx = + struct class type t = object inherit Elpi.API.Conversion.ctx end end let rec elpi_embed_tctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> fun elpi__state -> function - | (elpi__10, TDecl (elpi__8, elpi__9)) -> + | (elpi__9, TDecl (elpi__7, elpi__8)) -> + let (elpi__state, elpi__13, elpi__10) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__9 in let (elpi__state, elpi__14, elpi__11) = - Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__10 in - let (elpi__state, elpi__15, elpi__12) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__8 in - let (elpi__state, elpi__16, elpi__13) = + elpi__constraints elpi__state elpi__7 in + let (elpi__state, elpi__15, elpi__12) = Elpi.Builtin.PPX.embed_bool ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__9 in + elpi__constraints elpi__state elpi__8 in (elpi__state, (Elpi.API.RawData.mkAppL elpi_constant_constructor_tctx_TDeclc - [elpi__14; elpi__15; elpi__16]), - (List.concat [elpi__11; elpi__12; elpi__13])) + [elpi__13; elpi__14; elpi__15]), + (List.concat [elpi__10; elpi__11; elpi__12])) let rec elpi_readback_tctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> @@ -110,19 +110,20 @@ include match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_tctx_TDeclc -> - let (elpi__state, elpi__7, elpi__6) = - Elpi.API.PPX.readback_nominal ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__x in + let (elpi__state, elpi__6, elpi__5) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in (match elpi__xs with - | elpi__2::elpi__3::[] -> - let (elpi__state, elpi__2, elpi__4) = + | elpi__1::elpi__2::[] -> + let (elpi__state, elpi__1, elpi__3) = Elpi.API.PPX.readback_string ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__2 in - let (elpi__state, elpi__3, elpi__5) = + elpi__hyps elpi__constraints elpi__state elpi__1 in + let (elpi__state, elpi__2, elpi__4) = Elpi.Builtin.PPX.readback_bool ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__3 in - (elpi__state, (elpi__7, (TDecl (elpi__2, elpi__3))), - (List.concat [elpi__6; elpi__4; elpi__5])) + elpi__hyps elpi__constraints elpi__state elpi__2 in + (elpi__state, (elpi__6, (TDecl (elpi__1, elpi__2))), + (List.concat [elpi__5; elpi__3; elpi__4])) | _ -> Elpi.API.Utils.type_error ("Not enough arguments to constructor: " ^ @@ -133,91 +134,60 @@ include (Format.asprintf "Not a constructor of type %s: %a" "tctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) let tctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * tctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + 'c . + ((Elpi.API.RawData.constant * tctx), #Ctx_for_tctx.t as 'c) + Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "tctx" in + let kind = Elpi.API.Conversion.TyName "tctx" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"tctx"; Elpi.API.PPX.Doc.constructor fmt - ~ty:(Elpi.API.ContextualConversion.TyName "prop") - ~name:"tdecl" ~doc:"TDecl" - ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty]); + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"tdecl" + ~doc:"TDecl" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty]); pp = (fun fmt -> fun (_, x) -> pp_tctx fmt x); embed = elpi_embed_tctx; readback = elpi_readback_tctx } - let in_tctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state = - let module CMap = Elpi.API.RawData.Constants.Map in - let elpi__filtered_hyps = - List.fold_left - (fun elpi__m -> - fun - ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as - elpi__hyp) - -> - match elpi_is_tctx ~depth:elpi__i elpi__hsrc with - | None -> elpi__m - | Some elpi__idx -> - (if CMap.mem elpi__idx elpi__m - then - Elpi.API.Utils.type_error - "more than one context entry for the same nominal"; - CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty - (Elpi.API.RawData.of_hyps elpi__hyps) in - let rec elpi__aux elpi__state elpi__gls elpi__i = - if elpi__i = elpi__depth - then (elpi__state, (List.concat (List.rev elpi__gls))) - else - if not (CMap.mem elpi__i elpi__filtered_hyps) - then elpi__aux elpi__state elpi__gls (elpi__i + 1) - else - (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in - let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in - let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = - tctx.Elpi.API.ContextualConversion.readback - ~depth:elpi__hyp_depth elpi__hyps elpi__constraints - elpi__state elpi__hyp.Elpi.API.RawData.hsrc in - assert (elpi__nominal = elpi__i); - (let elpi__s = elpi_tctx_to_key ~depth:elpi__hyp_depth elpi__t in - let elpi__state = - elpi_push_tctx ~depth:elpi__i elpi__state elpi__s - { - Elpi.API.ContextualConversion.entry = elpi__t; - depth = elpi__hyp_depth - } in - elpi__aux elpi__state (elpi__gls_t :: elpi__gls) - (elpi__i + 1))) in - let elpi__state = - Elpi.API.State.set elpi_tctx_state elpi__state - (Elpi_tctx_Map.empty, CMap.empty) in - let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in - let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_tctx_state elpi__state in - (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) - let in_tctx = in_tctx_alone - let elpi_tctx = Elpi.API.BuiltIn.MLDataC tctx - let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_tctx] @ [])) + let context_made_of_tctx = + { + Elpi.API.Conversion.is_entry_for_nominal = elpi_is_tctx; + to_key = elpi_tctx_to_key; + push = elpi_push_tctx; + pop = elpi_pop_tctx; + conv = tctx; + init = + (fun state -> + Elpi.API.State.set elpi_tctx_state state + ((Elpi_tctx_Map.empty : Elpi.API.RawData.constant + Elpi_tctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : tctx + Elpi.API.Conversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))); + get = + (fun state -> snd @@ (Elpi.API.State.get elpi_tctx_state state)) + } + let elpi_tctx = Elpi.API.BuiltIn.MLData tctx + class ctx_for_tctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tctx.t = + object (_) inherit ((Elpi.API.Conversion.ctx) h) end + let (in_ctx_for_tctx : Ctx_for_tctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> fun s -> (s, ((new ctx_for_tctx) h s), (List.concat [])) + let () = declaration := ((!declaration) @ [elpi_tctx]) end[@@ocaml.doc "@inline"][@@merlin.hide ] let pp_tye _ _ = () type tye = - | TVar of string [@elpi.var ] + | TVar of string [@elpi.var tctx] | TConst of string - | TArrow of tye * tye [@@deriving - elpi - { - context = (x : tye -> tctx); - append = elpi_stuff - }] + | TArrow of tye * tye [@@deriving elpi { declaration }] include struct [@@@warning "-26-27-32-39-60"] @@ -236,11 +206,17 @@ include let elpi_constant_constructor_tye_TArrowc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_tye_TArrow + module Ctx_for_tye = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_tye : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (tye, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (tye, #Ctx_for_tye.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -276,10 +252,7 @@ include [elpi__35; elpi__36]), (List.concat [elpi__33; elpi__34])) let rec elpi_readback_tye : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (tye, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (tye, #Ctx_for_tye.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -298,10 +271,9 @@ include (Format.asprintf "Unbound variable: %s in %a" (Elpi.API.RawData.Constants.show elpi__hd) (Elpi.API.RawData.Constants.Map.pp - (Elpi.API.ContextualConversion.pp_ctx_entry - pp_tctx)) elpi__dbl2ctx); - (let { - Elpi.API.ContextualConversion.entry = elpi__entry; + (Elpi.API.Conversion.pp_ctx_entry pp_tctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd @@ -345,75 +317,52 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "tye" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let tye : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (tye, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "tye" in + let tye : 'c . (tye, #Ctx_for_tye.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "tye" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"tye"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tconst" ~doc:"TConst" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty]; + ~args:[Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"tarrow" ~doc:"TArrow" - ~args:[Elpi.API.ContextualConversion.TyName - elpi_constant_type_tye; - Elpi.API.ContextualConversion.TyName - elpi_constant_type_tye]); + ~args:[Elpi.API.Conversion.TyName elpi_constant_type_tye; + Elpi.API.Conversion.TyName elpi_constant_type_tye]); pp = pp_tye; embed = elpi_embed_tye; readback = elpi_readback_tye } - let elpi_tye = Elpi.API.BuiltIn.MLDataC tye - let () = - elpi_stuff := - ((!elpi_stuff) @ - ([elpi_tye] @ - [Elpi.API.BuiltIn.LPCode - (String.concat "\n" - ["pred map.tye i:tye, o:tye."; - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "tye" "" - "tvar" "A0" "tvar" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "tye" "" - "tconst" "A0" "tconst" "B0" - (String.concat ", " - ["(" ^ - ("(=)" ^ (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")")))))]); - Printf.sprintf "map.%s %s(%s %s) (%s %s) :- %s." "tye" "" - "tarrow" "A0 A1" "tarrow" "B0 B1" - (String.concat ", " - ["(" ^ - (("map." ^ elpi_constant_type_tye) ^ - (" " ^ ("A0" ^ (" " ^ ("B0" ^ ")"))))); - "(" ^ - (("map." ^ elpi_constant_type_tye) ^ - (" " ^ ("A1" ^ (" " ^ ("B1" ^ ")")))))]); - "\n"])])) + let elpi_tye = Elpi.API.BuiltIn.MLData tye + class ctx_for_tye (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_tye.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_tye : Ctx_for_tye.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx + h c s in + (s, ((new ctx_for_tye) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_tye]) end[@@ocaml.doc "@inline"][@@merlin.hide ] +let tye : 'a . (tye, #ctx_for_tye as 'a) Elpi.API.Conversion.t = tye let pp_ty _ _ = () type ty = | Mono of tye | Forall of string * bool * - ((ty)[@elpi.binder tye (fun s -> fun b -> TDecl (s, b))]) [@@deriving - elpi - { - context = - (x : - ((tye -> - tctx) * - (ty -> - tctx))) - }] + ((ty)[@elpi.binder "tye" tctx (fun s -> fun b -> TDecl (s, b))]) [@@deriving + elpi] include struct [@@@warning "-26-27-32-39-60"] @@ -428,11 +377,17 @@ include let elpi_constant_constructor_ty_Forallc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_ty_Forall + module Ctx_for_ty = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_ty : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -440,9 +395,8 @@ include function | Mono elpi__45 -> let (elpi__state, elpi__47, elpi__46) = - tye.Elpi.API.ContextualConversion.embed - ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state elpi__45 in + tye.Elpi.API.Conversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__45 in (elpi__state, (Elpi.API.RawData.mkAppL elpi_constant_constructor_ty_Monoc [elpi__47]), @@ -460,7 +414,7 @@ include elpi_tctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = @@ -479,10 +433,7 @@ include [elpi__54; elpi__55; elpi__56]), (List.concat [elpi__51; elpi__52; elpi__53])) let rec elpi_readback_ty : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -492,9 +443,8 @@ include | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_ty_Monoc -> let (elpi__state, elpi__38, elpi__37) = - tye.Elpi.API.ContextualConversion.readback - ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state elpi__x in + tye.Elpi.API.Conversion.readback ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__x in (match elpi__xs with | [] -> (elpi__state, (Mono elpi__38), @@ -522,8 +472,7 @@ include elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = - elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = @@ -553,44 +502,51 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "ty" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let ty : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (ty, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "ty" in + let ty : 'c . (ty, #Ctx_for_ty.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "ty" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"ty"; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"mono" - ~doc:"Mono" ~args:[tye.Elpi.API.ContextualConversion.ty]; + ~doc:"Mono" ~args:[tye.Elpi.API.Conversion.ty]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"forall" ~doc:"Forall" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) Elpi.Builtin.bool).Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyApp - ("->", (Elpi.API.ContextualConversion.TyName "tye"), - [Elpi.API.ContextualConversion.TyName - elpi_constant_type_ty])]); + ~args:[Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + Elpi.Builtin.bool.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "tye"), + [Elpi.API.Conversion.TyName elpi_constant_type_ty])]); pp = pp_ty; embed = elpi_embed_ty; readback = elpi_readback_ty } - let elpi_ty = Elpi.API.BuiltIn.MLDataC ty + let elpi_ty = Elpi.API.BuiltIn.MLData ty + class ctx_for_ty (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_ty.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_ty : Ctx_for_ty.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx + h c s in + (s, ((new ctx_for_ty) h s), (List.concat [gls0])) end[@@ocaml.doc "@inline"][@@merlin.hide ] +let ty : 'a . (ty, #ctx_for_ty as 'a) Elpi.API.Conversion.t = ty let pp_ctx _ _ = () type ctx = - | Decl of ((string)[@elpi.key ]) * ty [@@deriving - elpi - { - index = (module String); - context = (x : tctx); - append = elpi_stuff - }] + | Decl of ((string)[@elpi.key ]) * ty [@@elpi.index (module String)] +[@@deriving elpi { declaration; context = [tctx] }] include struct [@@@warning "-26-27-32-39-60"] @@ -609,10 +565,10 @@ include ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant Elpi_ctx_Map.t), (Elpi.API.RawData.Constants.Map.empty : ctx - Elpi.API.ContextualConversion.ctx_entry + Elpi.API.Conversion.ctx_entry Elpi.API.RawData.Constants.Map.t))) - let elpi_ctx_to_key ~depth:_ = function | Decl (elpi__58, _) -> elpi__58 - let elpi_is_ctx ~depth:elpi__depth elpi__x = + let elpi_ctx_to_key ~depth:_ = function | Decl (elpi__73, _) -> elpi__73 + let elpi_is_ctx { Elpi.API.Data.hdepth = elpi__depth; hsrc = elpi__x } = match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.Const _ -> None | Elpi.API.RawData.App (elpi__hd, elpi__idx, _) -> @@ -649,35 +605,45 @@ include Elpi.API.State.set elpi_ctx_state elpi__state (elpi__ctx2dbl, elpi__dbl2ctx) in elpi__state + module Ctx_for_ctx = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.embedding + 'c . + ((Elpi.API.RawData.constant * ctx), #Ctx_for_ctx.t as 'c) + Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> fun elpi__state -> function - | (elpi__67, Decl (elpi__65, elpi__66)) -> + | (elpi__66, Decl (elpi__64, elpi__65)) -> + let (elpi__state, elpi__70, elpi__67) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.embed + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__66 in let (elpi__state, elpi__71, elpi__68) = - Elpi.API.PPX.embed_nominal ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__67 in - let (elpi__state, elpi__72, elpi__69) = Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps - elpi__constraints elpi__state elpi__65 in - let (elpi__state, elpi__73, elpi__70) = - ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__66 in + elpi__constraints elpi__state elpi__64 in + let (elpi__state, elpi__72, elpi__69) = + ty.Elpi.API.Conversion.embed ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state elpi__65 in (elpi__state, (Elpi.API.RawData.mkAppL elpi_constant_constructor_ctx_Declc - [elpi__71; elpi__72; elpi__73]), - (List.concat [elpi__68; elpi__69; elpi__70])) + [elpi__70; elpi__71; elpi__72]), + (List.concat [elpi__67; elpi__68; elpi__69])) let rec elpi_readback_ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.readback + 'c . + ((Elpi.API.RawData.constant * ctx), #Ctx_for_ctx.t as 'c) + Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> @@ -687,22 +653,23 @@ include match Elpi.API.RawData.look ~depth:elpi__depth elpi__x with | Elpi.API.RawData.App (elpi__hd, elpi__x, elpi__xs) when elpi__hd == elpi_constant_constructor_ctx_Declc -> - let (elpi__state, elpi__64, elpi__63) = - Elpi.API.PPX.readback_nominal ~depth:elpi__depth - elpi__hyps elpi__constraints elpi__state elpi__x in + let (elpi__state, elpi__63, elpi__62) = + Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.readback + ~depth:elpi__depth elpi__hyps elpi__constraints + elpi__state elpi__x in (match elpi__xs with - | elpi__59::elpi__60::[] -> - let (elpi__state, elpi__59, elpi__61) = + | elpi__58::elpi__59::[] -> + let (elpi__state, elpi__58, elpi__60) = Elpi.API.PPX.readback_string ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__58 in + let (elpi__state, elpi__59, elpi__61) = + ty.Elpi.API.Conversion.readback ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__59 in - let (elpi__state, elpi__60, elpi__62) = - ty.Elpi.API.ContextualConversion.readback - ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state elpi__60 in (elpi__state, - (elpi__64, (Decl (elpi__59, elpi__60))), - (List.concat [elpi__63; elpi__61; elpi__62])) + (elpi__63, (Decl (elpi__58, elpi__59))), + (List.concat [elpi__62; elpi__60; elpi__61])) | _ -> Elpi.API.Utils.type_error ("Not enough arguments to constructor: " ^ @@ -713,87 +680,69 @@ include (Format.asprintf "Not a constructor of type %s: %a" "ctx" (Elpi.API.RawPp.term elpi__depth) elpi__x) let ctx : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - ((Elpi.API.RawData.constant * ctx), 'elpi__param__poly_hyps, - 'elpi__param__poly_csts) Elpi.API.ContextualConversion.t + 'c . + ((Elpi.API.RawData.constant * ctx), #Ctx_for_ctx.t as 'c) + Elpi.API.Conversion.t = - let kind = Elpi.API.ContextualConversion.TyName "ctx" in + let kind = Elpi.API.Conversion.TyName "ctx" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"ctx"; Elpi.API.PPX.Doc.constructor fmt - ~ty:(Elpi.API.ContextualConversion.TyName "prop") - ~name:"decl" ~doc:"Decl" - ~args:[Elpi.API.PPX.nominal.Elpi.API.ContextualConversion.ty; - (Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - ty.Elpi.API.ContextualConversion.ty]); + ~ty:(Elpi.API.Conversion.TyName "prop") ~name:"decl" + ~doc:"Decl" + ~args:[Elpi.API.BuiltInData.nominal.Elpi.API.Conversion.ty; + Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + ty.Elpi.API.Conversion.ty]); pp = (fun fmt -> fun (_, x) -> pp_ctx fmt x); embed = elpi_embed_ctx; readback = elpi_readback_ctx } - let in_ctx_alone ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state = - let module CMap = Elpi.API.RawData.Constants.Map in - let elpi__filtered_hyps = - List.fold_left - (fun elpi__m -> - fun - ({ Elpi.API.RawData.hdepth = elpi__i; hsrc = elpi__hsrc } as - elpi__hyp) - -> - match elpi_is_ctx ~depth:elpi__i elpi__hsrc with - | None -> elpi__m - | Some elpi__idx -> - (if CMap.mem elpi__idx elpi__m - then - Elpi.API.Utils.type_error - "more than one context entry for the same nominal"; - CMap.add elpi__idx elpi__hyp elpi__m)) CMap.empty - (Elpi.API.RawData.of_hyps elpi__hyps) in - let rec elpi__aux elpi__state elpi__gls elpi__i = - if elpi__i = elpi__depth - then (elpi__state, (List.concat (List.rev elpi__gls))) - else - if not (CMap.mem elpi__i elpi__filtered_hyps) - then elpi__aux elpi__state elpi__gls (elpi__i + 1) - else - (let elpi__hyp = CMap.find elpi__i elpi__filtered_hyps in - let elpi__hyp_depth = elpi__hyp.Elpi.API.RawData.hdepth in - let (elpi__state, (elpi__nominal, elpi__t), elpi__gls_t) = - ctx.Elpi.API.ContextualConversion.readback - ~depth:elpi__hyp_depth elpi__hyps elpi__constraints - elpi__state elpi__hyp.Elpi.API.RawData.hsrc in - assert (elpi__nominal = elpi__i); - (let elpi__s = elpi_ctx_to_key ~depth:elpi__hyp_depth elpi__t in - let elpi__state = - elpi_push_ctx ~depth:elpi__i elpi__state elpi__s - { - Elpi.API.ContextualConversion.entry = elpi__t; - depth = elpi__hyp_depth - } in - elpi__aux elpi__state (elpi__gls_t :: elpi__gls) - (elpi__i + 1))) in - let elpi__state = - Elpi.API.State.set elpi_ctx_state elpi__state - (Elpi_ctx_Map.empty, CMap.empty) in - let (elpi__state, elpi__gls) = elpi__aux elpi__state [] 0 in - let (_, elpi__dbl2ctx) = - Elpi.API.State.get elpi_ctx_state elpi__state in - (elpi__state, elpi__dbl2ctx, elpi__constraints, elpi__gls) - let in_ctx = - Elpi.API.ContextualConversion.(|+|) in_tctx_alone in_ctx_alone - let elpi_ctx = Elpi.API.BuiltIn.MLDataC ctx - let () = elpi_stuff := ((!elpi_stuff) @ ([elpi_ctx] @ [])) + let context_made_of_ctx = + { + Elpi.API.Conversion.is_entry_for_nominal = elpi_is_ctx; + to_key = elpi_ctx_to_key; + push = elpi_push_ctx; + pop = elpi_pop_ctx; + conv = ctx; + init = + (fun state -> + Elpi.API.State.set elpi_ctx_state state + ((Elpi_ctx_Map.empty : Elpi.API.RawData.constant + Elpi_ctx_Map.t), + (Elpi.API.RawData.Constants.Map.empty : ctx + Elpi.API.Conversion.ctx_entry + Elpi.API.RawData.Constants.Map.t))); + get = (fun state -> snd @@ (Elpi.API.State.get elpi_ctx_state state)) + } + let elpi_ctx = Elpi.API.BuiltIn.MLData ctx + class ctx_for_ctx (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_ctx.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_ctx : Ctx_for_ctx.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx + h c s in + (s, ((new ctx_for_ctx) h s), (List.concat [gls0])) + let () = declaration := ((!declaration) @ [elpi_ctx]) end[@@ocaml.doc "@inline"][@@merlin.hide ] type term = - | Var of string [@elpi.var ] + | Var of string [@elpi.var ctx] | App of term list [@elpi.code "appl"][@elpi.doc "bla bla"] | Lam of string * ty * - ((term)[@elpi.binder term (fun s -> fun ty -> Decl (s, ty))]) + ((term)[@elpi.binder ctx (fun s -> fun ty -> Decl (s, ty))]) | Literal of int [@elpi.skip ] | Cast of term * ty [@elpi.embed @@ -811,32 +760,16 @@ type term = fun state -> fun l -> default ~depth hyps constraints state l] [@elpi.code "type-cast" "term -> ty -> term"][@@deriving elpi - { - context = - (x : ((ty -> tctx) * - (term -> ctx))) - }][@@elpi.pp - let rec aux fmt = - function - | Var s -> - Format.fprintf - fmt "%s" s - | App tl -> - Format.fprintf - fmt "App %a" - (Elpi.API.RawPp.list - aux " ") tl - | Lam (s, ty, t) -> - Format.fprintf - fmt - "Lam %s (%a)" - s aux t - | Literal i -> - Format.fprintf - fmt "%d" i - | Cast (t, _) -> - aux fmt t in - aux] + { context = [tctx; ctx] }] +[@@elpi.pp + let rec aux fmt = + function + | Var s -> Format.fprintf fmt "%s" s + | App tl -> Format.fprintf fmt "App %a" (Elpi.API.RawPp.list aux " ") tl + | Lam (s, ty, t) -> Format.fprintf fmt "Lam %s (%a)" s aux t + | Literal i -> Format.fprintf fmt "%d" i + | Cast (t, _) -> aux fmt t in + aux] include struct [@@@warning "-26-27-32-39-60"] @@ -860,11 +793,19 @@ include let elpi_constant_constructor_term_Castc = Elpi.API.RawData.Constants.declare_global_symbol elpi_constant_constructor_term_Cast + module Ctx_for_term = + struct + class type t = + object + inherit Elpi.API.Conversion.ctx + inherit Ctx_for_tctx.t + method tctx : tctx Elpi.API.Conversion.ctx_field + inherit Ctx_for_ctx.t + method ctx : ctx Elpi.API.Conversion.ctx_field + end + end let rec elpi_embed_term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.embedding - = + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.embedding = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -893,7 +834,7 @@ include Elpi.API.PPX.embed_string ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__94 in let (elpi__state, elpi__101, elpi__98) = - ty.Elpi.API.ContextualConversion.embed ~depth:elpi__depth + ty.Elpi.API.Conversion.embed ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__95 in let elpi__ctx_entry = (fun s -> fun ty -> Decl (s, ty)) elpi__94 elpi__95 in @@ -901,7 +842,7 @@ include elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = @@ -942,7 +883,7 @@ include elpi__hyps elpi__constraints elpi__state elpi__104 in let (elpi__state, elpi__109, elpi__107) = - ty.Elpi.API.ContextualConversion.embed + ty.Elpi.API.Conversion.embed ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__105 in (elpi__state, @@ -953,10 +894,7 @@ include ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__104 elpi__105 let rec elpi_readback_term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.readback - = + 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.readback = fun ~depth:elpi__depth -> fun elpi__hyps -> fun elpi__constraints -> @@ -975,10 +913,9 @@ include (Format.asprintf "Unbound variable: %s in %a" (Elpi.API.RawData.Constants.show elpi__hd) (Elpi.API.RawData.Constants.Map.pp - (Elpi.API.ContextualConversion.pp_ctx_entry - pp_ctx)) elpi__dbl2ctx); - (let { - Elpi.API.ContextualConversion.entry = elpi__entry; + (Elpi.API.Conversion.pp_ctx_entry pp_ctx)) + elpi__dbl2ctx); + (let { Elpi.API.Conversion.entry = elpi__entry; depth = elpi__depth } = Elpi.API.RawData.Constants.Map.find elpi__hd @@ -1009,9 +946,9 @@ include (match elpi__xs with | elpi__78::elpi__79::[] -> let (elpi__state, elpi__78, elpi__80) = - ty.Elpi.API.ContextualConversion.readback - ~depth:elpi__depth elpi__hyps elpi__constraints - elpi__state elpi__78 in + ty.Elpi.API.Conversion.readback ~depth:elpi__depth + elpi__hyps elpi__constraints elpi__state + elpi__78 in let elpi__ctx_entry = (fun s -> fun ty -> Decl (s, ty)) elpi__83 elpi__78 in @@ -1019,8 +956,7 @@ include elpi_ctx_to_key ~depth:elpi__depth elpi__ctx_entry in let elpi__ctx_entry = { - Elpi.API.ContextualConversion.entry = - elpi__ctx_entry; + Elpi.API.Conversion.entry = elpi__ctx_entry; depth = elpi__depth } in let elpi__state = @@ -1068,7 +1004,7 @@ include | elpi__84::[] -> let (elpi__state, elpi__84, elpi__85) = - ty.Elpi.API.ContextualConversion.readback + ty.Elpi.API.Conversion.readback ~depth:elpi__depth elpi__hyps elpi__constraints elpi__state elpi__84 in @@ -1086,10 +1022,10 @@ include ~loc:{ Elpi.API.Ast.Loc.source_name = "test_two_layers_context.ml"; - source_start = 1777; - source_stop = 1777; - line = 49; - line_starts_at = 1766 + source_start = 1815; + source_stop = 1815; + line = 55; + line_starts_at = 1804 } "standard branch readback takes 1 argument or more") ~depth:elpi__depth elpi__hyps elpi__constraints @@ -1098,33 +1034,27 @@ include Elpi.API.Utils.type_error (Format.asprintf "Not a constructor of type %s: %a" "term" (Elpi.API.RawPp.term elpi__depth) elpi__x) - let term : - 'elpi__param__poly_hyps 'elpi__param__poly_csts . - (term, 'elpi__param__poly_hyps, 'elpi__param__poly_csts) - Elpi.API.ContextualConversion.t - = - let kind = Elpi.API.ContextualConversion.TyName "term" in + let term : 'c . (term, #Ctx_for_term.t as 'c) Elpi.API.Conversion.t = + let kind = Elpi.API.Conversion.TyName "term" in { - Elpi.API.ContextualConversion.ty = kind; + Elpi.API.Conversion.ty = kind; pp_doc = (fun fmt -> fun () -> Elpi.API.PPX.Doc.kind fmt kind ~doc:"term"; (Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"appl" ~doc:"bla bla" - ~args:[Elpi.API.ContextualConversion.TyApp + ~args:[Elpi.API.Conversion.TyApp ("list", - (Elpi.API.ContextualConversion.TyName + (Elpi.API.Conversion.TyName elpi_constant_type_term), [])]; Elpi.API.PPX.Doc.constructor fmt ~ty:kind ~name:"lam" ~doc:"Lam" - ~args:[(Elpi.API.ContextualConversion.(!>) - Elpi.API.BuiltInData.string).Elpi.API.ContextualConversion.ty; - ty.Elpi.API.ContextualConversion.ty; - Elpi.API.ContextualConversion.TyApp - ("->", - (Elpi.API.ContextualConversion.TyName "term"), - [Elpi.API.ContextualConversion.TyName + ~args:[Elpi.API.BuiltInData.string.Elpi.API.Conversion.ty; + ty.Elpi.API.Conversion.ty; + Elpi.API.Conversion.TyApp + ("->", (Elpi.API.Conversion.TyName "term"), + [Elpi.API.Conversion.TyName elpi_constant_type_term])]); Format.fprintf fmt "@[type %s@[ %s. %% %s@]@]@\n" "type-cast" "term -> ty -> term" "Cast"); @@ -1141,41 +1071,56 @@ include embed = elpi_embed_term; readback = elpi_readback_term } - let elpi_term = Elpi.API.BuiltIn.MLDataC term + let elpi_term = Elpi.API.BuiltIn.MLData term + class ctx_for_term (h : Elpi.API.Data.hyps) (s : Elpi.API.Data.state) + : Ctx_for_term.t = + object (_) + inherit ((Elpi.API.Conversion.ctx) h) + inherit ! ((ctx_for_tctx) h s) + method tctx = context_made_of_tctx.Elpi.API.Conversion.get s + inherit ! ((ctx_for_ctx) h s) + method ctx = context_made_of_ctx.Elpi.API.Conversion.get s + end + let (in_ctx_for_term : Ctx_for_term.t Elpi.API.Conversion.ctx_readback) = + fun ~depth -> + fun h -> + fun c -> + fun s -> + let ctx = (new ctx_for_tctx) h s in + let (s, gls0) = + Elpi.API.PPX.readback_context ~depth context_made_of_tctx ctx + h c s in + let ctx = (new ctx_for_ctx) h s in + let (s, gls1) = + Elpi.API.PPX.readback_context ~depth context_made_of_ctx ctx + h c s in + (s, ((new ctx_for_term) h s), (List.concat [gls0; gls1])) end[@@ocaml.doc "@inline"][@@merlin.hide ] +let term : 'a . (term, #ctx_for_term as 'a) Elpi.API.Conversion.t = term open Elpi.API open BuiltInPredicate open Notation let term_to_string = Pred ("term->string", - (CIn - (term, "T", - (COut - ((ContextualConversion.(!>) BuiltInData.string), "S", - (Read (in_ctx, "what else")))))), + (In (term, "T", (Out (BuiltInData.string, "S", (Read "what else"))))), + in_ctx_for_term, (fun (t : term) -> fun (_ety : string oarg) -> fun ~depth:_ -> - fun - ((ctx1, ctx2) : - (tctx ContextualConversion.ctx_entry RawData.Constants.Map.t - * ctx ContextualConversion.ctx_entry - RawData.Constants.Map.t)) - -> + fun c -> fun (_cst : Data.constraints) -> fun (_state : State.t) -> !: (Format.asprintf "@[%a@ %a@ |-@ %a@]@\n%!" (RawData.Constants.Map.pp - (ContextualConversion.pp_ctx_entry pp_tctx)) ctx1 + (Conversion.pp_ctx_entry pp_tctx)) c#tctx (RawData.Constants.Map.pp - (ContextualConversion.pp_ctx_entry pp_ctx)) ctx2 - term.pp t))) + (Conversion.pp_ctx_entry pp_ctx)) c#ctx term.pp t))) let builtin = let open BuiltIn in declare ~file_name:"test_ppx.elpi" - ((!elpi_stuff) @ + ((!declaration) @ ([MLCode (term_to_string, DocAbove); LPDoc "----------------- elpi ----------------"] @ (let open Elpi.Builtin in core_builtins @ elpi_builtins))) diff --git a/ppx_elpi/tests/test_two_layers_context.ml b/ppx_elpi/tests/test_two_layers_context.ml index 5b5ca8ef6..4a316e2ce 100644 --- a/ppx_elpi/tests/test_two_layers_context.ml +++ b/ppx_elpi/tests/test_two_layers_context.ml @@ -1,4 +1,4 @@ -let elpi_stuff = ref [] +let declaration = ref [] module String = struct include String @@ -8,38 +8,44 @@ end let pp_tctx _ _ = () type tctx = TDecl of (string[@elpi.key]) * bool -[@@deriving elpi { index = (module String) ; append = elpi_stuff } ] + [@@elpi.index (module String)] +[@@deriving elpi { declaration } ] let pp_tye _ _ = () type tye = - | TVar of string [@elpi.var] + | TVar of string [@elpi.var tctx] | TConst of string | TArrow of tye * tye -[@@deriving elpi { context = (x : (tye -> tctx) ) ; append = elpi_stuff } ] +[@@deriving elpi { declaration } ] + +let tye : 'a. (tye, #ctx_for_tye as 'a) Elpi.API.Conversion.t = tye let pp_ty _ _ = () type ty = | Mono of tye - | Forall of string * bool * (ty[@elpi.binder tye (fun s b -> TDecl(s,b))]) -[@@deriving elpi { context = (x : (tye -> tctx) * (ty -> tctx)) }] + | Forall of string * bool * (ty[@elpi.binder "tye" tctx (fun s b -> TDecl(s,b))]) +[@@deriving elpi ] + +let ty : 'a. (ty, #ctx_for_ty as 'a) Elpi.API.Conversion.t = ty let pp_ctx _ _ = () type ctx = Decl of (string[@elpi.key]) * ty -[@@deriving elpi { index = (module String); context = (x : tctx) ; append = elpi_stuff } ] + [@@elpi.index (module String)] +[@@deriving elpi { declaration ; context = [tctx] } ] type term = - | Var of string [@elpi.var] + | Var of string [@elpi.var ctx] | App of term list [@elpi.code "appl"] [@elpi.doc "bla bla"] - | Lam of string * ty * (term[@elpi.binder term (fun s ty -> Decl(s,ty))]) + | Lam of string * ty * (term[@elpi.binder ctx (fun s ty -> Decl(s,ty))]) | Literal of int [@elpi.skip] | Cast of term * ty (* Example: override the embed and readback code for this constructor *) [@elpi.embed fun default ~depth hyps constraints state a1 a2 -> - default ~depth hyps constraints state a1 a2 ] + default ~depth hyps constraints state a1 a2 ] [@elpi.readback fun default ~depth hyps constraints state l -> default ~depth hyps constraints state l ] [@elpi.code "type-cast" "term -> ty -> term"] -[@@deriving elpi { context = (x : (ty -> tctx) * (term -> ctx)) } ] +[@@deriving elpi { context = [ tctx ; ctx ] } ] [@@elpi.pp let rec aux fmt = function | Var s -> Format.fprintf fmt "%s" s | App tl -> Format.fprintf fmt "App %a" (Elpi.API.RawPp.list aux " ") tl @@ -48,27 +54,28 @@ type term = | Cast(t,_) -> aux fmt t in aux ] +let term : 'a. (term, #ctx_for_term as 'a) Elpi.API.Conversion.t = term + open Elpi.API open BuiltInPredicate open Notation let term_to_string = Pred("term->string", - CIn(term,"T", - COut(ContextualConversion.(!>) BuiltInData.string,"S", - Read(in_ctx, "what else"))), + In(term,"T", + Out(BuiltInData.string,"S", + Read("what else"))), in_ctx_for_term, fun (t : term) (_ety : string oarg) - ~depth:_ ((ctx1,ctx2) : tctx ContextualConversion.ctx_entry RawData.Constants.Map.t * ctx ContextualConversion.ctx_entry RawData.Constants.Map.t) - (_cst : Data.constraints) (_state : State.t) -> + ~depth:_ c (_cst : Data.constraints) (_state : State.t) -> !: (Format.asprintf "@[%a@ %a@ |-@ %a@]@\n%!" - (RawData.Constants.Map.pp (ContextualConversion.pp_ctx_entry pp_tctx)) ctx1 - (RawData.Constants.Map.pp (ContextualConversion.pp_ctx_entry pp_ctx)) ctx2 + (RawData.Constants.Map.pp (Conversion.pp_ctx_entry pp_tctx)) c#tctx + (RawData.Constants.Map.pp (Conversion.pp_ctx_entry pp_ctx)) c#ctx term.pp t) ) let builtin = let open BuiltIn in - declare ~file_name:"test_ppx.elpi" (!elpi_stuff @ [ + declare ~file_name:"test_ppx.elpi" (!declaration @ [ MLCode(term_to_string,DocAbove); LPDoc "----------------- elpi ----------------" ] @ Elpi.Builtin.(core_builtins @ elpi_builtins)) @@ -100,4 +107,4 @@ let main () = | _ -> exit 1 ;; -main () \ No newline at end of file +main () From 0a1bf493f55e6d16173dc12b611f5cabcdb0b62e Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 22:51:03 +0200 Subject: [PATCH 6/7] wip --- src/API.ml | 26 +++++++++++++++----------- src/API.mli | 4 ++++ src/builtin.ml | 4 ---- src/builtin.mli | 4 ---- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/API.ml b/src/API.ml index f4fc578e0..610358d13 100644 --- a/src/API.ml +++ b/src/API.ml @@ -1065,19 +1065,23 @@ module Doc = struct 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_int ~depth h c s x = BuiltInData.int.Conversion.readback ~depth (new Conversion.ctx h#raw) c s x + let readback_float ~depth h c s x = BuiltInData.float.Conversion.readback ~depth (new Conversion.ctx h#raw) c s x + let readback_string ~depth h c s x = BuiltInData.string.Conversion.readback ~depth (new Conversion.ctx h#raw) 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 readback_loc ~depth h c s x = BuiltInData.loc.Conversion.readback ~depth (new Conversion.ctx h#raw) c s x + let readback_nominal ~depth h c s x = BuiltInData.nominal.Conversion.readback ~depth (new Conversion.ctx h#raw) c s x + let readback_bool ~depth h c s x = BuiltInData.bool.Conversion.readback ~depth (new Conversion.ctx h#raw) c s x + let readback_char ~depth h c s x = BuiltInData.char.Conversion.readback ~depth (new Conversion.ctx h#raw) c s x + + let embed_int ~depth h c s x = BuiltInData.int.Conversion.embed ~depth (new Conversion.ctx h#raw) c s x + let embed_float ~depth h c s x = BuiltInData.float.Conversion.embed ~depth (new Conversion.ctx h#raw) c s x + let embed_string ~depth h c s x = BuiltInData.string.Conversion.embed ~depth (new Conversion.ctx h#raw) 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 + let embed_loc ~depth h c s x = BuiltInData.loc.Conversion.embed ~depth (new Conversion.ctx h#raw) c s x + let embed_nominal ~depth h c s x = BuiltInData.nominal.Conversion.embed ~depth (new Conversion.ctx h#raw) c s x + let embed_bool ~depth h c s x = BuiltInData.bool.Conversion.embed ~depth (new Conversion.ctx h#raw) c s x + let embed_char ~depth h c s x = BuiltInData.char.Conversion.embed ~depth (new Conversion.ctx h#raw) c s x type context_description = | C : ('a,'k,'c) Conversion.context -> context_description diff --git a/src/API.mli b/src/API.mli index 95358de32..1f8c770ea 100644 --- a/src/API.mli +++ b/src/API.mli @@ -1165,6 +1165,8 @@ module PPX : sig 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 readback_bool : (bool, 'h) Conversion.readback + val readback_char : (char, 'h) Conversion.readback val embed_int : (int, 'c) Conversion.embedding val embed_float : (float, 'c) Conversion.embedding @@ -1172,6 +1174,8 @@ module PPX : sig 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 + val embed_bool : (bool, 'h) Conversion.embedding + val embed_char : (char, 'h) Conversion.embedding type context_description = | C : ('a,'k,'c) Conversion.context -> context_description diff --git a/src/builtin.ml b/src/builtin.ml index c67883100..0ea697441 100644 --- a/src/builtin.ml +++ b/src/builtin.ml @@ -1391,8 +1391,6 @@ module PPX = struct let readback_pair = readback_pair let readback_option = readback_option - let readback_bool ~depth _ c s x = bool.API.Conversion.readback ~depth (new Conversion.ctx []) c s x - let readback_char ~depth _ c s x = char.API.Conversion.readback ~depth (new Conversion.ctx []) c s x let readback_triple = readback_triple let readback_quadruple = readback_quadruple @@ -1400,8 +1398,6 @@ module PPX = struct let embed_pair = embed_pair let embed_option = embed_option - let embed_bool ~depth _ c s x = bool.API.Conversion.embed ~depth (new Conversion.ctx []) c s x - let embed_char ~depth _ c s x = char.API.Conversion.embed ~depth (new Conversion.ctx []) c s x let embed_triple = embed_triple let embed_quadruple = embed_quadruple diff --git a/src/builtin.mli b/src/builtin.mli index 329eaf31c..d298485da 100644 --- a/src/builtin.mli +++ b/src/builtin.mli @@ -60,8 +60,6 @@ module PPX : sig val readback_pair : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('a * 'b, 'h) API.Conversion.readback val readback_option : ('a, 'h) API.Conversion.readback -> ('a option, 'h) API.Conversion.readback - val readback_bool : (bool, 'h) API.Conversion.readback - val readback_char : (char, 'h) API.Conversion.readback val readback_triple : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('c, 'h) API.Conversion.readback -> ('a * 'b * 'c, 'h) API.Conversion.readback val readback_quadruple : ('a, 'h) API.Conversion.readback -> ('b, 'h) API.Conversion.readback -> ('c, 'h) API.Conversion.readback -> ('d, 'h) API.Conversion.readback -> ('a * 'b * 'c * 'd, 'h) API.Conversion.readback @@ -69,8 +67,6 @@ module PPX : sig val embed_pair : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('a * 'b, 'h) API.Conversion.embedding val embed_option : ('a, 'h) API.Conversion.embedding -> ('a option, 'h) API.Conversion.embedding - val embed_bool : (bool, 'h) API.Conversion.embedding - val embed_char : (char, 'h) API.Conversion.embedding val embed_triple : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('c, 'h) API.Conversion.embedding -> ('a * 'b * 'c, 'h) API.Conversion.embedding val embed_quadruple : ('a, 'h) API.Conversion.embedding -> ('b, 'h) API.Conversion.embedding -> ('c, 'h) API.Conversion.embedding -> ('d, 'h) API.Conversion.embedding -> ('a * 'b * 'c * 'd, 'h) API.Conversion.embedding From e8a4b0eabdbd28e48075916f094040101f57f6bc Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 30 Apr 2020 14:37:38 +0200 Subject: [PATCH 7/7] rebased --- ppx_elpi/ppx_elpi.ml | 46 +++++++++--------------------- ppx_elpi/tests/test_opaque_type.ml | 11 ++++++- 2 files changed, 23 insertions(+), 34 deletions(-) diff --git a/ppx_elpi/ppx_elpi.ml b/ppx_elpi/ppx_elpi.ml index 8044e518e..7107414f0 100644 --- a/ppx_elpi/ppx_elpi.ml +++ b/ppx_elpi/ppx_elpi.ml @@ -723,8 +723,8 @@ let conversion_of (module B : Ast_builder.S) ty = let open B in | [%type: string] -> [%expr Elpi.API.BuiltInData.string] | [%type: int] -> [%expr Elpi.API.BuiltInData.int] | [%type: float] -> [%expr Elpi.API.BuiltInData.float] - | [%type: bool] -> [%expr Elpi.Builtin.bool] - | [%type: char] -> [%expr Elpi.Builtin.char] + | [%type: bool] -> [%expr Elpi.API.BuiltInData.bool] + | [%type: char] -> [%expr Elpi.API.BuiltInData.char] | [%type: [%t? typ] list] -> [%expr Elpi.API.BuiltInData.list [%e aux typ ]] | [%type: [%t? typ] option] -> [%expr Elpi.Builtin.option [%e aux typ ]] | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.Builtin.pair [%e aux typ1 ] [%e aux typ2 ]] @@ -747,8 +747,8 @@ let rec find_embed_of (module B : Ast_builder.S) current_mutrec_block ty = let | [%type: string] -> [%expr Elpi.API.PPX.embed_string] | [%type: int] -> [%expr Elpi.API.PPX.embed_int] | [%type: float] -> [%expr Elpi.API.PPX.embed_float] - | [%type: bool] -> [%expr Elpi.Builtin.PPX.embed_bool] - | [%type: char] -> [%expr Elpi.Builtin.PPX.embed_char] + | [%type: bool] -> [%expr Elpi.API.PPX.embed_bool] + | [%type: char] -> [%expr Elpi.API.PPX.embed_char] | [%type: [%t? typ] list] -> [%expr Elpi.API.PPX.embed_list [%e aux typ ]] | [%type: [%t? typ] option] -> [%expr Elpi.Builtin.PPX.embed_option [%e aux typ ]] | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.Builtin.PPX.embed_pair [%e aux typ1 ] [%e aux typ2 ]] @@ -768,8 +768,8 @@ let rec find_readback_of (module B : Ast_builder.S) current_mutrec_block ty = l | [%type: string] -> [%expr Elpi.API.PPX.readback_string] | [%type: int] -> [%expr Elpi.API.PPX.readback_int] | [%type: float] -> [%expr Elpi.API.PPX.readback_float] - | [%type: bool] -> [%expr Elpi.Builtin.PPX.readback_bool] - | [%type: char] -> [%expr Elpi.Builtin.PPX.readback_char] + | [%type: bool] -> [%expr Elpi.API.PPX.readback_bool] + | [%type: char] -> [%expr Elpi.API.PPX.readback_char] | [%type: [%t? typ] list] -> [%expr Elpi.API.PPX.readback_list [%e aux typ ]] | [%type: [%t? typ] option] -> [%expr Elpi.Builtin.PPX.readback_option [%e aux typ ]] | [%type: [%t? typ1] * [%t? typ2]] -> [%expr Elpi.Builtin.PPX.readback_pair [%e aux typ1 ] [%e aux typ2 ]] @@ -1108,32 +1108,12 @@ let coversion_for_opaque (module B : Ast_builder.S) elpi_name name = let open B [%type: ( [%t ptyp_constr (Located.lident name) []] , #Elpi.API.Conversion.ctx as 'c) Elpi.API.Conversion.t])) ~expr:[%expr - let name = [%e elpi_name ] in - let { Elpi.API.RawOpaqueData.cin; isc; cout; name=c }, constants_map, doc = [%e evar @@ elpi_cdata_name name ] in - - let ty = Elpi.API.Conversion.TyName name in - let embed ~depth:_ _ _ state x = - state, Elpi.API.RawData.mkCData (cin x), [] in - let readback ~depth _ _ state t = - match Elpi.API.RawData.look ~depth t with - | Elpi.API.RawData.CData c when isc c -> state, cout c, [] - | Elpi.API.RawData.Const i when i < 0 -> - begin try state, snd @@ Elpi.API.RawData.Constants.Map.find i constants_map, [] - with Not_found -> raise (Elpi.API.Conversion.TypeErr(ty,depth,t)) end - | _ -> raise (Elpi.API.Conversion.TypeErr(ty,depth,t)) in - let pp_doc fmt () = - if doc <> "" then begin - Elpi.API.PPX.Doc.comment fmt ("% " ^ doc); - Format.fprintf fmt "@\n"; - end; - Format.fprintf fmt "@[typeabbrev %s (ctype \"%s\").@]@\n@\n" name c; - Elpi.API.RawData.Constants.Map.iter (fun _ (c,_) -> - Format.fprintf fmt "@[type %s %s.@]@\n" c name) - constants_map - in - { Elpi.API.Conversion.embed; readback; ty; pp_doc; pp = (fun fmt x -> Elpi.API.RawOpaqueData.pp fmt (cin x)) } - - ] + let ty, pp, pp_doc, cdata = [%e evar @@ elpi_cdata_name name ] in { + Elpi.API.Conversion.ty; pp_doc; pp; + embed = (fun ~depth -> Elpi.API.OpaqueData.embed cdata ~depth); + readback = (fun ~depth -> Elpi.API.OpaqueData.readback cdata ~depth); + } + ] let abstract_expr_over_params (module B : Ast_builder.S) vl f e = let open B in let rec aux = function @@ -1276,7 +1256,7 @@ let constants_of_tyd (module B : Ast_builder.S) { type_decl ; elpi_name; name; _ | Opaque opaque_data -> [pstr_value Nonrecursive [ value_binding ~pat:(pvar @@ elpi_cdata_name name) - ~expr:[%expr Elpi.API.RawOpaqueData.declare [%e opaque_data]]]] + ~expr:[%expr Elpi.API.OpaqueData.declare [%e opaque_data]]]] | Algebraic (csts,_) -> List.flatten @@ List.map (fun x -> x.declaration) @@ drop_skip csts let elpi_declaration_of_tyd (module B : Ast_builder.S) tyd = let open B in diff --git a/ppx_elpi/tests/test_opaque_type.ml b/ppx_elpi/tests/test_opaque_type.ml index f81f4f1a9..2e1430adf 100644 --- a/ppx_elpi/tests/test_opaque_type.ml +++ b/ppx_elpi/tests/test_opaque_type.ml @@ -1,7 +1,16 @@ let elpi_stuff = ref [] let pp_simple _ _ = () -type simple [@@elpi.opaque {Elpi.API.OpaqueData.name = "simple"; doc = ""; pp = (fun fmt _ -> Format.fprintf fmt ""); compare = Pervasives.compare; hash = Hashtbl.hash; hconsed = false; constants = []; } ] +type simple [@@elpi.opaque { Elpi.API.OpaqueData. + name = "simple"; + cname = "simple"; + doc = "a simple opaque data type"; + pp = (fun fmt _ -> Format.fprintf fmt ""); + compare = Pervasives.compare; + hash = Hashtbl.hash; + hconsed = false; + constants = []; +}] [@@deriving elpi { declaration = elpi_stuff }] open Elpi.API