From 10d43dc33c9b0ddc2286eadb4e1a9b51eb465f13 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Apr 2020 14:01:16 +0200 Subject: [PATCH 1/6] 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 e0efada01a8ea5ad8d4e1076273d9f3d2007dbbe Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 16:35:35 +0200 Subject: [PATCH 2/6] API: only one conversion type indexed by a context object --- CHANGES.md | 20 + Makefile | 2 +- src/.ppcache/API.ml | 884 +++++++++++++++++++++++------ src/.ppcache/API.mli | 481 +++++++++------- src/.ppcache/builtin.ml | 0 src/.ppcache/builtin.mli | 56 ++ src/.ppcache/compiler.ml | 42 +- src/.ppcache/compiler.mli | 6 +- src/.ppcache/data.ml | 646 ++++++++------------- src/.ppcache/runtime_trace_off.ml | 204 +++---- src/.ppcache/runtime_trace_off.mli | 5 +- src/.ppcache/runtime_trace_on.ml | 204 +++---- src/.ppcache/runtime_trace_on.mli | 5 +- src/API.ml | 496 +++++++++++----- src/API.mli | 487 +++++++++------- src/builtin.elpi | 65 ++- src/builtin.ml | 437 ++++++++------ src/builtin.mli | 22 +- src/builtin_map.elpi | 2 +- src/builtin_set.elpi | 2 +- src/compiler.ml | 12 +- src/compiler.mli | 2 +- src/data.ml | 299 +++++----- src/dune | 10 +- src/elpi-checker.elpi | 3 +- src/merlinppx.ppx.ml | 2 +- src/runtime.ml | 106 +--- src/runtime.mli | 5 +- trace/ppx/trace_ppx.ml | 57 +- 29 files changed, 2664 insertions(+), 1898 deletions(-) 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 2b6ccaad6..98293560f 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 index 77fb0156c..ceb4b7bf2 100644 --- a/src/.ppcache/API.ml +++ b/src/.ppcache/API.ml @@ -1,4 +1,4 @@ -(*2186ca58e78b30b2616c65e76db3513ad756c89d *src/API.ml *) +(*09dd92d029bc5129509dbb9e46c435ff8be4de41 *src/API.ml --cookie elpi_trace="false"*) #1 "src/API.ml" module type Runtime = module type of Runtime_trace_off let r = ref ((module Runtime_trace_off) : (module Runtime)) @@ -37,7 +37,6 @@ module Setup = | 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 @@ -114,6 +113,7 @@ module Data = 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 = { @@ -126,6 +126,7 @@ module Data = hdepth: int ; hsrc: term } type hyps = hyp list + module Constants = struct module Map = Data.Constants.Map end end module Compile = struct @@ -185,13 +186,64 @@ module Pp = 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 + struct + type extra_goals = ED.extra_goals + include ED.Conversion + let (^^) t = + { + t with + embed = + (fun ~depth -> + fun h -> + fun c -> + fun s -> fun x -> t.embed ~depth ((new ctx) h#raw) c s x); + readback = + (fun ~depth -> + fun h -> + fun c -> + fun s -> fun x -> t.readback ~depth ((new ctx) h#raw) c s x) + } + end module RawOpaqueData = struct include Util.CData include ED.C + let { cin = of_char; isc = is_char; cout = to_char } as char = + declare + { + data_compare = Pervasives.compare; + data_pp = (fun fmt -> fun 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) -> fun (_, s2) -> String.compare s1 s2); + data_pp = + (fun fmt -> fun (_, 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) -> fun (_, s2) -> String.compare s1 s2); + data_pp = + (fun fmt -> fun (_, 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) type name = string type doc = string type 'a declaration = @@ -203,17 +255,19 @@ module RawOpaqueData = hash: 'a -> int ; hconsed: bool ; constants: (name * 'a) list } - let conversion_of_cdata ~name ?(doc= "") ~constants_map ~constants + let conversion_of_cdata ~name ?(doc= "") ~constants_map { 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 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), []) + (try + (state, (snd @@ (ED.Constants.Map.find i constants_map)), + []) with | Not_found -> raise (Conversion.TypeErr (ty, depth, t))) | t -> raise (Conversion.TypeErr (ty, depth, t)) in @@ -226,10 +280,11 @@ module RawOpaqueData = 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 + ED.Constants.Map.iter + (fun _ -> + fun (c, _) -> + Format.fprintf fmt "@[type %s %s.@]@\n" c name) + constants_map in { Conversion.embed = embed; readback; @@ -237,16 +292,6 @@ module RawOpaqueData = 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 @@ -257,7 +302,14 @@ module RawOpaqueData = data_name = name; data_hconsed = hconsed } in - (cdata, (conversion_of_cdata ~name ~doc ~constants cdata)) + (cdata, + (List.fold_right + (fun (n, v) -> + ED.Constants.Map.add + (ED.Global_symbols.declare_global_symbol n) (n, v)) constants + ED.Constants.Map.empty), doc) + let declare_cdata (cd, constants_map, doc) = + conversion_of_cdata ~name:(cd.Util.CData.name) ~doc ~constants_map cd end module OpaqueData = struct @@ -272,122 +324,8 @@ module OpaqueData = 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 () -> ()) - } + let declare x = + (x |> RawOpaqueData.declare) |> RawOpaqueData.declare_cdata end module Elpi = struct @@ -508,14 +446,9 @@ module RawData = 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 ; + context: Data.hyps ; goal: (int * term) } type constraints = Data.constraints let constraints l = @@ -637,15 +570,526 @@ module FlexibleData = 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), [])); + fun _ -> + fun _ -> + 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))) + fun _ -> + fun _ -> + 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 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 () = () + let int : 'h . (int, 'h) Conversion.t = + let name = "int" in + let doc = "" in + let cdata = ED.C.int in + let constants = [] in + let constants_map = ED.Constants.Map.empty in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + let float : 'h . (float, 'h) Conversion.t = + let name = "float" in + let doc = "" in + let cdata = ED.C.float in + let constants = [] in + let constants_map = ED.Constants.Map.empty in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + let string : 'h . (string, 'h) Conversion.t = + let name = "string" in + let doc = "" in + let cdata = ED.C.string in + let constants = [] in + let constants_map = ED.Constants.Map.empty in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + let loc : 'h . (Util.Loc.t, 'h) Conversion.t = + let name = "loc" in + let doc = "" in + let cdata = ED.C.loc in + let constants = [] in + let constants_map = ED.Constants.Map.empty in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + let char : 'h . (char, 'h) Conversion.t = + let name = "char" in + let doc = "an octect" in + let cdata = RawOpaqueData.char in + let constants = [] in + let constants_map = ED.Constants.Map.empty in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + let in_stream_constants = [("std_in", (stdin, "stdin"))] + let in_stream_cmap = + List.fold_left + (fun m -> + fun (c, v) -> + let c = ED.Global_symbols.declare_global_symbol c in + ED.Constants.Map.add c v m) ED.Constants.Map.empty + in_stream_constants + let in_stream : 'h . ((in_channel * string), 'h) Conversion.t = + let name = "in_stream" in + let doc = "" in + let cdata = RawOpaqueData.in_stream in + let constants = in_stream_constants in + let constants_map = in_stream_cmap in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + let out_stream_constants = + [("std_out", (stdout, "stdout")); ("std_err", (stderr, "stderr"))] + let out_stream_cmap = + List.fold_left + (fun m -> + fun (c, v) -> + let c = ED.Global_symbols.declare_global_symbol c in + ED.Constants.Map.add c v m) ED.Constants.Map.empty + out_stream_constants + let out_stream : 'h . ((out_channel * string), 'h) Conversion.t = + let name = "out_stream" in + let doc = "" in + let cdata = RawOpaqueData.out_stream in + let constants = out_stream_constants in + let constants_map = out_stream_cmap in + let { Util.CData.cin = cin; isc; cout; name = c } = cdata in + 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 -> Util.CData.pp fmt (cin x)) + } + 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 = + let embed ~depth:_ _ _ state x = (state, x, []) in + let readback ~depth _ _ state t = (state, t, []) in + { + Conversion.embed = embed; + readback; + ty = (Conversion.TyName "any"); + pp = (fun fmt -> fun _ -> Format.fprintf fmt ""); + pp_doc = (fun fmt -> fun () -> ()) + } + 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 = embed; + readback; + ty = (TyName "nominal"); + pp = (fun fmt -> fun d -> Format.fprintf fmt "%d" d); + pp_doc = (fun fmt -> fun () -> ()) + } + 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 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 -> fun () -> ()) + } + 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 + (let open Conversion in 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 -> + fun () -> + ED.BuiltInPredicate.ADT.document_adt + "Boolean values: tt and ff since true and false are predicates" + (let open Conversion in TyName "bool") + [("tt", "", ["bool"]); ("ff", "", ["bool"])] fmt ()); + pp = (fun fmt -> fun 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 -> + (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 + (let open Conversion in + TypeErr ((TyName "diagnostic"), depth, t))) + | _ -> + raise + (let open Conversion in + 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 -> + fun () -> + ED.BuiltInPredicate.ADT.document_adt + "Used in builtin variants that return Coq's error rather than failing" + (let open Conversion in 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 = @@ -664,8 +1108,8 @@ module BuiltInPredicate = include ED.BuiltInPredicate exception No_clause = ED.No_clause let mkData x = Data x - let ioargC a = - let open ContextualConversion in + let ioarg a = + let open Conversion in { a with pp = @@ -698,7 +1142,6 @@ module BuiltInPredicate = 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 { @@ -710,16 +1153,22 @@ module BuiltInPredicate = | NoData -> Format.fprintf fmt "_"); embed = (fun ~depth -> - fun state -> - function | Data x -> (state, x, []) | NoData -> assert false); + fun _ -> + fun _ -> + 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), [])) + fun _ -> + fun _ -> + 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 @@ -729,26 +1178,15 @@ module BuiltInPredicate = 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 + | D: ('a, Conversion.ctx) Conversion.t * 'a * 'x arguments -> 'x + arguments + | Q: ('a, Conversion.ctx) Conversion.t * name * 'x arguments -> ('a * + 'x) arguments type 'x t = | Query of { predicate: name ; @@ -811,6 +1249,8 @@ module Utils = 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 let module Data = ED.Term in @@ -880,4 +1320,90 @@ module RawPp = 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 = 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 -> + fun 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 diff --git a/src/.ppcache/API.mli b/src/.ppcache/API.mli index c1ae9a0a4..2549891bc 100644 --- a/src/.ppcache/API.mli +++ b/src/.ppcache/API.mli @@ -1,4 +1,4 @@ -(*927d066a4a64bd8ebdf616cca09a2e6c6b896a27 *src/API.mli *) +(*262f7f42585df543898448e5ff436973e6f64995 *src/API.mli --cookie elpi_trace="false"*) #1 "src/API.mli" [@@@ocaml.text " This module is the API for clients of the Elpi library. "] [@@@ocaml.text @@ -77,8 +77,21 @@ sig state: state ; output: 'a ; pp_ctx: pretty_printer_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 @@ -141,74 +154,60 @@ sig | 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 = + class ctx : Data.hyps -> object method raw : Data.hyps end + type ('a, 'c) embedding = depth:int -> - 'hyps -> - 'constraints -> - Data.state -> - 'a -> (Data.state * Data.term * Conversion.extra_goals) - type ('a, 'hyps, 'constraints) readback = + 'c -> + Data.constraints -> + Data.state -> 'a -> (Data.state * Data.term * extra_goals) + constraint + 'c = + #ctx + type ('a, 'c) readback = depth:int -> - 'hyps -> - 'constraints -> - Data.state -> - Data.term -> (Data.state * 'a * Conversion.extra_goals) - type ('a, 'h, 'c) t = + 'c -> + Data.constraints -> + Data.state -> Data.term -> (Data.state * 'a * extra_goals) + constraint + 'c = + #ctx + type ('a, '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 = + embed: ('a, 'c) embedding ; + readback: ('a, 'c) readback } constraint 'c = #ctx + val (^^) : ('a, ctx) t -> ('a, 'c) t + 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, '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 * '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 + Data.constraints -> Data.state -> (Data.state * 'c * extra_goals) + constraint 'c = #ctx + type dummy + val in_raw_ctx : ctx ctx_readback + val in_raw : (dummy, dummy, #ctx as 'a) context 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 "] + " This module defines what embedding and readback functions are "] module OpaqueData : sig type doc = string @@ -223,7 +222,7 @@ sig 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 + val declare : 'a declaration -> ('a, 'c) 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 : @@ -243,40 +242,32 @@ sig | B of 'build_t | BS of 'build_stateful_t type ('stateful_builder, 'builder, 'stateful_matcher, 'matcher, 'self, - 'hyps, 'constraints) constructor_arguments = + 'c) 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) + Data.term, 'self, 'c) constructor_arguments + | A: ('a, 'c) Conversion.t * ('bs, 'b, 'ms, 'm, 'self, 'c) 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) + 'self, 'c) constructor_arguments + | S: ('bs, 'b, 'ms, 'm, 'self, 'c) constructor_arguments -> + ('self -> 'bs, 'self -> 'b, 'self -> 'ms, 'self -> 'm, 'self, 'c) 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 = + | C: (('self, 'c) Conversion.t -> ('a, 'c) Conversion.t) * ('bs, + 'b, 'ms, 'm, 'self, 'c) constructor_arguments -> ('a -> 'bs, 'a -> 'b, + 'a -> 'ms, 'a -> 'm, 'self, 'c) 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, '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 = + 'match_t, 't, 'c) constructor_arguments * ('build_stateful_t, 'build_t) + build_t * ('match_stateful_t, 'match_t, 't) match_t -> ('t, 'c) + constructor + type ('t, '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 + constructors: ('t, 'c) constructor list } constraint 'c = #Conversion.ctx + val declare : ('t, 'c) declaration -> ('t, 'c) Conversion.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 : @@ -290,54 +281,46 @@ sig 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 -> + 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 -> Data.constraints -> Data.state -> 'o, + 'o, 'h) ffi + | Full: 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 -> + '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 -> - '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 -> + 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 -> - 'c -> Data.state -> (Data.state * ('o * 't option list option)), - 'o, 'h, 'c) ffi + 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 + | Pred: name * ('a, unit, 'h) ffi * 'h Conversion.ctx_readback * '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 + val ioarg : ('t, 'c) Conversion.t -> ('t ioarg, 'c) Conversion.t + val ioarg_any : (Data.term ioarg, 'c) Conversion.t module Notation : sig val (?:) : 'a -> (unit * 'a) @@ -354,8 +337,7 @@ sig " 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 + | MLData: ('a, 'c) Conversion.t -> declaration | LPDoc of string | LPCode of string val declare : file_name:string -> declaration list -> Setup.builtins @@ -370,8 +352,10 @@ 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 + | D: ('a, Conversion.ctx) Conversion.t * 'a * 'x arguments -> 'x + arguments + | Q: ('a, Conversion.ctx) Conversion.t * name * 'x arguments -> ('a * 'x) + arguments type 'x t = | Query of { predicate: name ; @@ -434,9 +418,89 @@ sig 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 + val uvar : ((Elpi.t * Data.term list), 'c) 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 BuiltInData : +sig + val int : (int, 'c) Conversion.t[@@ocaml.doc + " See Elpi_builtin for a few more "] + 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 + 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 + val poly : string -> (Data.term, 'c) Conversion.t + val closed : string -> ((Data.term * int), 'c) Conversion.t + val any : (Data.term, 'c) Conversion.t + val nominal : (Data.constant, 'c) Conversion.t +end[@@ocaml.doc " Conversion for Elpi's built-in data types "] +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 printf : ('a, Format.formatter, unit) format -> 'a[@@ocaml.doc + " alias for printf and eprintf that write on the formatters set in Setup "] + val eprintf : ('a, Format.formatter, unit) format -> 'a + 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 : + (Data.state -> 't -> (Data.state * 'a * Conversion.extra_goals)) -> + Data.state -> + 't list -> (Data.state * '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 RawOpaqueData : sig type name = string @@ -458,7 +522,11 @@ sig isc: t -> bool ; cout: t -> 'a ; name: string } - val declare : 'a declaration -> ('a cdata * 'a Conversion.t) + val declare : + 'a declaration -> ('a cdata * (name * 'a) Data.Constants.Map.t * string) + val declare_cdata : + ('a cdata * (name * 'a) Data.Constants.Map.t * string) -> + ('a, 'c) Conversion.t val pp : Format.formatter -> t -> unit val show : t -> string val equal : t -> t -> bool @@ -486,11 +554,15 @@ sig val is_loc : t -> bool 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[@@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 constant = Data.constant[@@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 @@ -512,7 +584,7 @@ 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 val mkGlobal : constant -> term[@@ocaml.doc " Lower level smart constructors "] val mkApp : constant -> term -> term list -> term @@ -520,13 +592,8 @@ sig 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 ; + context: Data.hyps ; goal: (int * term) } val constraints : Data.constraints -> suspended_goal list val no_constraints : Data.constraints @@ -544,99 +611,52 @@ sig 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 + module Map = Data.Constants.Map + module Set : Utils.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 + Data.state -> + name:string -> args:Data.term list -> (Data.state * Data.term) + val is_Arg : Data.state -> Data.term -> bool val compile : Compile.program -> - (depth:int -> State.t -> (State.t * (Ast.Loc.t * Data.term))) -> - unit Compile.query + (depth:int -> + Data.hyps -> + Data.constraints -> + Data.state -> (Data.state * (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) + depth:int -> + Data.state -> Ast.Loc.t -> string -> (Data.state * 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}}] "] + " 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) "] + Data.state -> + 'a Compile.query -> (Data.state * 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!) "] + Data.state -> + 'a Compile.query -> (Data.state * Data.term list * Data.term) + val term_at : + depth:int -> Data.state -> Ast.query -> (Data.state * 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 + name:string -> (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 - 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 + name:string -> (Data.state -> string -> (Data.state * Data.term)) -> unit end module RawPp : sig @@ -655,5 +675,48 @@ sig val show_term : Data.term -> string end end +module PPX : +sig + [@@@ocaml.text " 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 [@@@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..2fcc25de2 100644 --- a/src/.ppcache/compiler.ml +++ b/src/.ppcache/compiler.ml @@ -1,4 +1,4 @@ -(*2d1e91f72ff28de5f87971da214ef74780dddbf1 *src/compiler.ml *) +(*460c62986d53adb8c20297ac71da3ae5b3c7414a *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"; @@ -2562,7 +2562,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 +2612,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) = @@ -2968,7 +2971,7 @@ let query_of_term compiler_state assembled_program f = let active_macros = assembled_program.Assembled.toplevel_macros in let (state, query) = 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 @@ -2993,9 +2996,12 @@ 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 + fun hyps -> + fun constraints -> + fun state -> + let (state, term) = + R.embed_query ~mk_Arg ~depth hyps constraints state descr in + (state, (loc, term))) in { query with query_arguments = arguments } module Compiler : sig val run : 'a query -> 'a executable end = struct @@ -3123,7 +3129,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 @@ -3359,12 +3365,16 @@ 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]))))) in let executable = optimize_query query in (exec executable) <> Failure diff --git a/src/.ppcache/compiler.mli b/src/.ppcache/compiler.mli index 9f803f783..e377c5e76 100644 --- a/src/.ppcache/compiler.mli +++ b/src/.ppcache/compiler.mli @@ -1,4 +1,4 @@ -(*d53ed81516fb5c87752f86676d2c2b0ac20ba07f *src/compiler.mli *) +(*236a6f802b725b0b7125f292daff8dfa43fe4334 *src/compiler.mli *) #1 "src/compiler.mli" open Util open Data @@ -22,7 +22,9 @@ 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))) + -> unit 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..0cf9acfbc 100644 --- a/src/.ppcache/data.ml +++ b/src/.ppcache/data.ml @@ -1,4 +1,4 @@ -(*83d0917ef4644ac288b486b091a03067003847df *src/data.ml *) +(*9e41ed19c2304eae433f81858bfaabcd5701c359 *src/data.ml *) #1 "src/data.ml" module Fmt = Format module F = Ast.Func @@ -1381,315 +1381,176 @@ 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 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), []) end let while_compiling = State.declare ~name:"elpi:compiling" ~pp:(fun fmt -> fun _ -> ()) @@ -1707,44 +1568,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 +1632,61 @@ 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, 'ctx) Conversion.t -> ('a, '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 h. look:(depth:int -> term -> term) -> Conversion.ty_ast -> depth:int -> h -> - c -> + constraints -> State.t -> extra_goals list -> term -> - (a, m, t, h, c) compiled_constructor_arguments -> + (a, m, t, h) compiled_constructor_arguments -> a -> term list -> (State.t * t * extra_goals) = fun ~look -> @@ -1865,16 +1716,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 h. 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, h) compiled_adt -> depth:int -> h -> - c -> State.t -> term -> (State.t * t * extra_goals) + constraints -> + State.t -> term -> (State.t * t * extra_goals) = fun ~mkinterval -> fun ~look -> @@ -1922,15 +1774,15 @@ 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 h. mkConst:(int -> term) -> Conversion.ty_ast -> - (t, h, c) compiled_adt -> + (t, h) compiled_adt -> constant -> depth:int -> h -> - c -> - (a, m, t, h, c) compiled_constructor_arguments -> + constraints -> + (a, m, t, h) compiled_constructor_arguments -> (State.t -> (State.t * term * extra_goals)) list -> m = @@ -1962,13 +1814,15 @@ module BuiltInPredicate = ((fun state -> d.embed ~depth hyps constraints state x) :: acc)) - and embed : type a h c. + and embed : type a h. mkConst:(int -> term) -> Conversion.ty_ast -> (Format.formatter -> a -> unit) -> - (a, h, c) compiled_adt -> + (a, h) compiled_adt -> depth:int -> - h -> c -> State.t -> a -> (State.t * term * extra_goals) + h -> + constraints -> + State.t -> a -> (State.t * term * extra_goals) = fun ~mkConst -> fun ty -> @@ -1993,38 +1847,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, 'h) constructor_arguments -> + (t, #Conversion.ctx as 'h) Conversion.t -> + (bs, ms, t, 'h) 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 +1885,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 +1892,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 +1910,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 +1939,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 +1982,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 +2015,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 +2064,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 +2074,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 +2091,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,10 +2105,12 @@ module BuiltInPredicate = module Query = struct type name = string - type _ arguments = + type 'x arguments = | N: unit arguments - | D: 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q: 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments + | D: ('a, Conversion.ctx) Conversion.t * 'a * 'x arguments -> 'x + arguments + | Q: ('a, Conversion.ctx) Conversion.t * name * 'x arguments -> ('a * + 'x) arguments type 'x t = | Query of { predicate: constant ; diff --git a/src/.ppcache/runtime_trace_off.ml b/src/.ppcache/runtime_trace_off.ml index 2bfe57cc8..dac471efd 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"*) +(*2cc741ee440ad7cd56532d0c52810aad119f1795 *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,62 +1784,12 @@ 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. @@ -1879,49 +1797,63 @@ let rec embed_query_aux : type a. depth:int -> predicate:constant -> term list -> - term list -> State.t -> a Query.arguments -> (State.t * term) + term list -> + hyps -> + constraints -> State.t -> a Query.arguments -> (State.t * term) = fun ~mk_Arg -> 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 hyps -> + fun constraints -> + fun state -> + fun descr -> + match descr with + | Data.Query.D (d, x, rest) -> + let (state, x, glsx) = + d.Conversion.embed ~depth + ((new Conversion.ctx) hyps) constraints state x in + embed_query_aux ~mk_Arg ~depth ~predicate + (gls @ glsx) (x :: args) hyps 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) hyps 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])))) +let embed_query ~mk_Arg ~depth hyps constraints state (Query.Query + { predicate; arguments }) = + embed_query_aux ~mk_Arg ~depth ~predicate [] [] hyps constraints state + arguments let rec query_solution_aux : type a. - a Query.arguments -> term StrMap.t -> State.t -> a = + a Query.arguments -> term StrMap.t -> hyps -> 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 hyps -> + fun constraints -> + fun state -> + match args with + | Data.Query.N -> () + | Data.Query.D (_, _, args) -> + query_solution_aux args assignments hyps constraints state + | Data.Query.Q (d, name, args) -> + let x = StrMap.find name assignments in + let (state, x, _gls) = + d.Conversion.readback ~depth:0 ((new Conversion.ctx) hyps) + constraints state x in + (x, + (query_solution_aux args assignments hyps constraints state)) +let output arguments assignments hyps constraints state = + query_solution_aux arguments assignments hyps constraints state module Indexing = struct let mustbevariablec = min_int @@ -3199,7 +3131,7 @@ let mk_outcome search get_cs assignments = assignments; constraints = syn_csts; state; - output = (output qargs assignments state); + output = (output qargs assignments [] syn_csts state); pp_ctx } in ((Success solution), alts) diff --git a/src/.ppcache/runtime_trace_off.mli b/src/.ppcache/runtime_trace_off.mli index 3e05312c9..e39fcf18d 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"*) +(*bf694777406dbb3b773e763e67beda1d5c6d725f *src/runtime_trace_off.mli --cookie elpi_trace="false"*) #1 "src/runtime_trace_off.mli" open Util open Data @@ -18,7 +18,8 @@ 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) 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..53b717613 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"*) +(*2cc741ee440ad7cd56532d0c52810aad119f1795 *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,62 +2275,12 @@ 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. @@ -2370,49 +2288,63 @@ let rec embed_query_aux : type a. depth:int -> predicate:constant -> term list -> - term list -> State.t -> a Query.arguments -> (State.t * term) + term list -> + hyps -> + constraints -> State.t -> a Query.arguments -> (State.t * term) = fun ~mk_Arg -> 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 hyps -> + fun constraints -> + fun state -> + fun descr -> + match descr with + | Data.Query.D (d, x, rest) -> + let (state, x, glsx) = + d.Conversion.embed ~depth + ((new Conversion.ctx) hyps) constraints state x in + embed_query_aux ~mk_Arg ~depth ~predicate + (gls @ glsx) (x :: args) hyps 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) hyps 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])))) +let embed_query ~mk_Arg ~depth hyps constraints state (Query.Query + { predicate; arguments }) = + embed_query_aux ~mk_Arg ~depth ~predicate [] [] hyps constraints state + arguments let rec query_solution_aux : type a. - a Query.arguments -> term StrMap.t -> State.t -> a = + a Query.arguments -> term StrMap.t -> hyps -> 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 hyps -> + fun constraints -> + fun state -> + match args with + | Data.Query.N -> () + | Data.Query.D (_, _, args) -> + query_solution_aux args assignments hyps constraints state + | Data.Query.Q (d, name, args) -> + let x = StrMap.find name assignments in + let (state, x, _gls) = + d.Conversion.readback ~depth:0 ((new Conversion.ctx) hyps) + constraints state x in + (x, + (query_solution_aux args assignments hyps constraints state)) +let output arguments assignments hyps constraints state = + query_solution_aux arguments assignments hyps constraints state module Indexing = struct let mustbevariablec = min_int @@ -4288,7 +4220,7 @@ let mk_outcome search get_cs assignments = assignments; constraints = syn_csts; state; - output = (output qargs assignments state); + output = (output qargs assignments [] syn_csts state); pp_ctx } in ((Success solution), alts) diff --git a/src/.ppcache/runtime_trace_on.mli b/src/.ppcache/runtime_trace_on.mli index edd347e46..275e4f32e 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"*) +(*bf694777406dbb3b773e763e67beda1d5c6d725f *src/runtime_trace_on.mli --cookie elpi_trace="true"*) #1 "src/runtime_trace_on.mli" open Util open Data @@ -18,7 +18,8 @@ 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) 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..99310c734 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,14 +206,45 @@ 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 include Util.CData include ED.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) + type name = string type doc = string @@ -224,18 +258,18 @@ module RawOpaqueData = struct constants : (name * 'a) list; (* global constants of that type, eg "std_in" *) } - let conversion_of_cdata ~name ?(doc="") ~constants_map ~constants + let conversion_of_cdata ~name ?(doc="") ~constants_map { cin; isc; cout; name=c } = let ty = Conversion.TyName name in - let embed ~depth:_ state x = + let embed ~depth:_ _ _ state x = state, ED.Term.CData (cin x), [] in - let readback ~depth state t = + 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, [] + begin try state, snd @@ 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 () = @@ -245,20 +279,12 @@ module RawOpaqueData = struct 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 + constants_map in { Conversion.embed; readback; ty; pp_doc; pp = (fun fmt 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; @@ -267,7 +293,13 @@ module RawOpaqueData = struct data_name = name; data_hconsed = hconsed; } in - cdata, conversion_of_cdata ~name ~doc ~constants cdata + cdata, + List.fold_right (fun (n,v) -> + ED.Constants.Map.add (ED.Global_symbols.declare_global_symbol n) (n,v)) + constants ED.Constants.Map.empty, doc + + let declare_cdata (cd,constants_map,doc) = + conversion_of_cdata ~name:cd.Util.CData.name ~doc ~constants_map cd end @@ -287,103 +319,7 @@ module OpaqueData = struct 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) - - 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 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 () -> ()) } + let declare x = x |> RawOpaqueData.declare |> RawOpaqueData.declare_cdata end @@ -530,16 +466,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 +593,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 +603,231 @@ 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[@elpi.template] inline_data = fun name doc cdata constants constants_map -> + let { Util.CData.cin; isc; cout; name=c } = cdata in + 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 () = + 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,_) -> + Format.fprintf fmt "@[type %s %s.@]@\n" c name) + constants in + { Conversion.embed; readback; ty; pp_doc; pp = (fun fmt x -> Util.CData.pp fmt (cin x)) } + + let int : 'h. (int, 'h) Conversion.t = [%elpi.template inline_data "int" "" ED.C.int [] ED.Constants.Map.empty] + let float : 'h. (float, 'h) Conversion.t = [%elpi.template inline_data "float" "" ED.C.float [] ED.Constants.Map.empty] + let string : 'h. (string, 'h) Conversion.t = [%elpi.template inline_data "string" "" ED.C.string [] ED.Constants.Map.empty] + let loc : 'h. (Util.Loc.t, 'h) Conversion.t = [%elpi.template inline_data "loc" "" ED.C.loc [] ED.Constants.Map.empty] + let char : 'h. (char, 'h) Conversion.t = [%elpi.template inline_data "char" "an octect" RawOpaqueData.char [] ED.Constants.Map.empty] + + let in_stream_constants = ["std_in",(stdin,"stdin")] + let in_stream_cmap = List.fold_left (fun m (c,v) -> + let c = ED.Global_symbols.declare_global_symbol c in + ED.Constants.Map.add c v m) + ED.Constants.Map.empty in_stream_constants + + let in_stream : 'h. (in_channel * string, 'h) Conversion.t = [%elpi.template inline_data "in_stream" "" RawOpaqueData.in_stream in_stream_constants in_stream_cmap] + + let out_stream_constants = ["std_out",(stdout,"stdout");"std_err",(stderr,"stderr")] + let out_stream_cmap = List.fold_left (fun m (c,v) -> + let c = ED.Global_symbols.declare_global_symbol c in + ED.Constants.Map.add c v m) + ED.Constants.Map.empty out_stream_constants + + let out_stream : 'h. (out_channel * string, 'h) Conversion.t = [%elpi.template inline_data "out_stream" "" RawOpaqueData.out_stream out_stream_constants out_stream_cmap] + + + 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 +849,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 +863,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,26 +888,12 @@ 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 + | D : ('a,Conversion.ctx) Conversion.t * 'a * 'x arguments -> 'x arguments + | Q : ('a,Conversion.ctx) Conversion.t * name * 'x arguments -> ('a * 'x) arguments type 'x t = Query of { predicate : name; arguments : 'x arguments } @@ -837,6 +973,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 +1050,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..afa6ed9ac 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 - - type ty_ast = Conversion.ty_ast = TyName of string | TyApp of string * ty_ast * ty_ast list - + val (^^) : ('a, ctx) t -> ('a, 'c) t - type ('a,'hyps,'constraints) embedding = - depth:int -> 'hyps -> 'constraints -> - Data.state -> 'a -> Data.state * Data.term * Conversion.extra_goals + 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,'hyps,'constraints) readback = - depth:int -> 'hyps -> 'constraints -> - Data.state -> Data.term -> Data.state * 'a * Conversion.extra_goals + type 'a ctx_field = 'a ctx_entry Data.Constants.Map.t - 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 @@ -340,7 +324,7 @@ module OpaqueData : sig constants : (name * 'a) list; (* global constants of that type, eg "std_in" *) } - val declare : 'a declaration -> 'a Conversion.t + val declare : 'a declaration -> ('a, 'c) Conversion.t end @@ -400,34 +384,33 @@ 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,'c) Conversion.t -> ('a,'c) 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 - val declare : ('t,'h,'c) declaration -> ('t,'h,'c) ContextualConversion.t + val declare : ('t,'c) declaration -> ('t,'c) Conversion.t end @@ -501,29 +484,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 +532,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 +581,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 @@ -655,8 +630,8 @@ 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 + | D : ('a,Conversion.ctx) Conversion.t * 'a * 'x arguments -> 'x arguments + | Q : ('a,Conversion.ctx) Conversion.t * name * 'x arguments -> ('a * 'x) arguments type 'x t = Query of { predicate : name; arguments : 'x arguments } @@ -790,7 +765,128 @@ 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 *) @@ -820,7 +916,8 @@ module RawOpaqueData : sig name : string; } - val declare : 'a declaration -> 'a cdata * 'a Conversion.t + val declare : 'a declaration -> 'a cdata * (name * 'a) Data.Constants.Map.t * string + val declare_cdata : 'a cdata * (name * 'a) Data.Constants.Map.t * string -> ('a,'c) Conversion.t val pp : Format.formatter -> t -> unit val show : t -> string @@ -857,6 +954,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 +968,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 +1003,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 +1013,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 +1044,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,14 +1058,14 @@ 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 val compile : - Compile.program -> (depth:int -> State.t -> State.t * (Ast.Loc.t * Data.term)) -> + Compile.program -> (depth:int -> Data.hyps -> Data.constraints -> Data.state -> Data.state * (Ast.Loc.t * Data.term)) -> unit Compile.query end @@ -977,24 +1073,24 @@ 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 +1098,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 +1127,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..26d197448 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,7 +917,7 @@ 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 { OpaqueData.name = "safe"; @@ -898,7 +984,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 +992,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 +1002,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 +1012,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 +1027,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 +1057,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 +1068,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 +1076,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 +1095,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 +1106,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,34 +1133,34 @@ 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) = - + (alpha : (a,Conversion.ctx) Conversion.t) (module Set : Util.Set.S with type elt = a) = + let set = OpaqueData.declare { OpaqueData.name; doc = ""; @@ -1087,21 +1173,21 @@ let set = OpaqueData.declare { 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 +1196,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 +1204,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 +1212,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 +1220,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,43 +1228,43 @@ 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 { @@ -1194,7 +1280,7 @@ let map = OpaqueData.declare { 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 +1288,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 +1305,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 +1313,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 +1321,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 +1330,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..c870077f0 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"; @@ -2008,7 +2008,7 @@ let query_of_term compiler_state assembled_program f = let state, query = 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 = @@ -2031,8 +2031,8 @@ let query_of_term compiler_state assembled_program f = 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 + let query = query_of_term state p (fun ~depth hyps constraints state -> + let state, term = R.embed_query ~mk_Arg ~depth hyps constraints state descr in state, (loc, term)) in { query with query_arguments = arguments } @@ -2160,7 +2160,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; @@ -2395,7 +2395,7 @@ 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 let executable = optimize_query query in diff --git a/src/compiler.mli b/src/compiler.mli index 11ae7cd89..e44ae6360 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)) -> unit 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..f0c042f0f 100644 --- a/src/data.ml +++ b/src/data.ml @@ -541,115 +541,85 @@ 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 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, [] + end let while_compiling = State.declare ~name:"elpi:compiling" @@ -668,23 +638,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 +690,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,'ctx) Conversion.t -> ('a,'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 +728,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 h. 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 -> h -> constraints -> State.t -> extra_goals list -> term -> + (a,m,t,h) 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 +756,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 h. 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,h) compiled_adt -> depth:int -> h -> 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 +782,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 h. 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,h) compiled_adt -> constant -> + depth:int -> h -> constraints -> + (a,m,t,h) compiled_constructor_arguments -> (State.t -> State.t * term * extra_goals) list -> m = fun ~mkConst ty adt kname ~depth hyps constraints args acc -> @@ -837,11 +803,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 h. mkConst:(int -> term) -> Conversion.ty_ast -> (Format.formatter -> a -> unit) -> - (a,h,c) compiled_adt -> - depth:int -> h -> c -> State.t -> + (a,h) compiled_adt -> + depth:int -> h -> constraints -> State.t -> a -> State.t * term * extra_goals = fun ~mkConst ty pp adt -> let bindings = Constants.Map.bindings adt in @@ -855,32 +821,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,'h) constructor_arguments -> (t,#Conversion.ctx as 'h) Conversion.t -> (bs,ms,t,'h) 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 +852,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 +861,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 +871,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 +888,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 +909,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 +944,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 +1000,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 +1021,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,10 +1036,10 @@ end module Query = struct type name = string - type _ arguments = + type 'x arguments = | N : unit arguments - | D : 'a Conversion.t * 'a * 'x arguments -> 'x arguments - | Q : 'a Conversion.t * name * 'x arguments -> ('a * 'x) arguments + | D : ('a,Conversion.ctx) Conversion.t * 'a * 'x arguments -> 'x arguments + | Q : ('a,Conversion.ctx) Conversion.t * name * 'x arguments -> ('a * 'x) arguments type 'x t = | Query of { predicate : constant; arguments : 'x arguments } @@ -1085,7 +1054,7 @@ type symbol_table = { [@@deriving show] 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; diff --git a/src/dune b/src/dune index 142fce86b..20ef10cfe 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\"" @@ -22,9 +20,11 @@ ((action (run ppxfindcache_elpi_trace_deriving_std %{input-file} --ppx-opt --cookie --ppx-opt "elpi_trace=\"false\"" + --cache-file %{dep:.ppcache/API.ml} + --cache-file %{dep:.ppcache/API.mli} --cache-file %{dep:.ppcache/runtime_trace_off.ml} --cache-file %{dep:.ppcache/runtime_trace_off.mli})) - runtime_trace_off) + runtime_trace_off API) ((action (run camlp5o -I . -I +camlp5 pa_extend.cmo pa_lexer.cmo %{input-file})) parser) )) (libraries re.str camlp5.gramlib unix elpi.trace.runtime @@ -88,7 +88,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..19ee800d3 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,76 +1939,44 @@ 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 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 -> hyps -> constraints -> State.t -> a Query.arguments -> State.t * term + = fun ~mk_Arg ~depth ~predicate gls args hyps 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 (new Conversion.ctx hyps) constraints state x in + embed_query_aux ~mk_Arg ~depth ~predicate (gls @ glsx) (x :: args) hyps 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 + embed_query_aux ~mk_Arg ~depth ~predicate gls (x :: args) hyps constraints state rest | Data.Query.N -> let args = List.rev args in state, @@ -2039,21 +1985,21 @@ let rec embed_query_aux : type a. mk_Arg:(State.t -> name:string -> args:term li | 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 +let embed_query ~mk_Arg ~depth hyps constraints state (Query.Query { predicate; arguments }) = + embed_query_aux ~mk_Arg ~depth ~predicate [] [] hyps constraints 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 Query.arguments -> term StrMap.t -> hyps -> constraints -> State.t -> a + = fun args assignments hyps 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 hyps 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 (new Conversion.ctx hyps) constraints state x in + x, query_solution_aux args assignments hyps constraints state -let output arguments assignments state = - query_solution_aux arguments assignments state +let output arguments assignments hyps constraints state = + query_solution_aux arguments assignments hyps constraints state (****************************************************************************** Indexing @@ -3437,7 +3383,7 @@ let mk_outcome search get_cs assignments = assignments; constraints = syn_csts; state; - output = output qargs assignments state; + output = output qargs assignments [] syn_csts state; pp_ctx = pp_ctx; } in Success solution, alts diff --git a/src/runtime.mli b/src/runtime.mli index b11a020b5..0f997d989 100644 --- a/src/runtime.mli +++ b/src/runtime.mli @@ -22,6 +22,7 @@ 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 -> + hyps -> constraints -> State.t -> 'a Query.t -> State.t * term (* Interpreter API *) @@ -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 diff --git a/trace/ppx/trace_ppx.ml b/trace/ppx/trace_ppx.ml index 9014adf2d..0cd179550 100644 --- a/trace/ppx/trace_ppx.ml +++ b/trace/ppx/trace_ppx.ml @@ -102,6 +102,22 @@ let tcall ~loc hd args = | f::a -> [%expr Obj.repr [%e eapply ~loc f a]] in [%expr raise (Trace_ppx_runtime.Runtime.TREC_CALL ([%e papp], Obj.repr [%e last]))] +let template_db : (string * expression) list ref = ref [] + +let template ~loc name args = + if not (List.mem_assoc name !template_db) then + Location.raise_errorf ~loc "template %s not found" name; + let e = List.assoc name !template_db in + let rec aux e = function + | [] -> e + | arg :: args -> + match e with + | [%expr fun [%p? name ] -> [%e? v] ] -> + [%expr let [%p name ] = [%e arg ] in [%e aux v args ]] + | _ -> Location.raise_errorf ~loc "template %s: too many arguments" name + in + aux e args + let enabled = ref false let has_iftrace_attribute (l : attributes) = @@ -109,6 +125,27 @@ let has_iftrace_attribute (l : attributes) = let has_iftrace { ptyp_attributes = l; _ } = has_iftrace_attribute l +let att_elpi_template = + let open Ppxlib.Ast_pattern in + Attribute.(declare "elpi.template" Context.value_binding (pstr nil) ()) + +let map_template = object + inherit Ast_traverse.map as super + + method! structure_item i = + let i = super#structure_item i in + match i.pstr_desc with + | Pstr_value(Nonrecursive, [ { pvb_pat = { ppat_desc = Ppat_var { txt; _ } ; _ }; _ } as vb]) -> + begin match Attribute.get att_elpi_template vb with + | Some () -> + template_db := (txt, vb.pvb_expr) :: !template_db; + let loc = i.pstr_loc in [%stri let () = ()] + | None -> i + end + | _ -> i + +end + let map_trace = object(self) inherit Ast_traverse.map as super @@ -311,6 +348,23 @@ let log_extension = let log_rule = Context_free.Rule.extension log_extension +(* ----------------------------------------------------------------- *) + +let template_expand_function ~loc ~path:_ e = match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident name; _}; _ }, args) -> + template ~loc name (List.map snd args) + | _ -> err ~loc "use: [%elpi.template id data..]" + +let template_extension = + Extension.declare + "elpi.template" + Extension.Context.expression + Ast_pattern.(single_expr_payload __) + template_expand_function + +let template_rule = Context_free.Rule.extension template_extension + + (* ----------------------------------------------------------------- *) (* ----------------------------------------------------------------- *) (* ----------------------------------------------------------------- *) @@ -323,7 +377,8 @@ let arg_trace t = let () = Driver.Cookies.add_handler arg_trace; Driver.register_transformation - ~rules:[ log_rule; cur_pred_rule; trace_rule; tcall_rule; spy_rule; spyl_rule; ] + ~preprocess_impl:map_template#structure + ~rules:[ log_rule; cur_pred_rule; trace_rule; tcall_rule; spy_rule; spyl_rule; template_rule ] ~impl:map_trace#structure ~intf:map_trace#signature "elpi.trace" \ No newline at end of file From cccf163492e8143b16587d8070cdb39bb9b5e5b5 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 16:51:26 +0200 Subject: [PATCH 3/6] 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 26d197448..e7ddbf63b 100644 --- a/src/builtin.ml +++ b/src/builtin.ml @@ -1374,3 +1374,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 20ef10cfe..0df554e9a 100644 --- a/src/dune +++ b/src/dune @@ -33,8 +33,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) @@ -58,6 +58,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 db5bb47f0d653a548005dc7505b452f8eff6b5fb Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 16:58:06 +0200 Subject: [PATCH 4/6] 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 98293560f..8628f6d8c 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 88c97d1a078d97cdc3ae23be4229263368193c73 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 26 Apr 2020 22:51:03 +0200 Subject: [PATCH 5/6] wip --- src/.ppcache/API.ml | 64 +++++++++++++++++++++++++++----------------- src/.ppcache/API.mli | 6 ++++- src/API.ml | 26 ++++++++++-------- src/API.mli | 4 +++ src/builtin.ml | 4 --- src/builtin.mli | 4 --- 6 files changed, 63 insertions(+), 45 deletions(-) diff --git a/src/.ppcache/API.ml b/src/.ppcache/API.ml index ceb4b7bf2..fae86cd04 100644 --- a/src/.ppcache/API.ml +++ b/src/.ppcache/API.ml @@ -1,4 +1,4 @@ -(*09dd92d029bc5129509dbb9e46c435ff8be4de41 *src/API.ml --cookie elpi_trace="false"*) +(*02b4f581e688efce20aa37de517a1147f85853f8 *src/API.ml --cookie elpi_trace="false"*) #1 "src/API.ml" module type Runtime = module type of Runtime_trace_off let r = ref ((module Runtime_trace_off) : (module Runtime)) @@ -1338,35 +1338,49 @@ module PPX = 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) []) + 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 = + 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) []) 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 + ((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 + 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/.ppcache/API.mli b/src/.ppcache/API.mli index 2549891bc..29a7f8360 100644 --- a/src/.ppcache/API.mli +++ b/src/.ppcache/API.mli @@ -1,4 +1,4 @@ -(*262f7f42585df543898448e5ff436973e6f64995 *src/API.mli --cookie elpi_trace="false"*) +(*a0dedc3be4f51309a9b50b6fd946f6c63f474e0c *src/API.mli --cookie elpi_trace="false"*) #1 "src/API.mli" [@@@ocaml.text " This module is the API for clients of the Elpi library. "] [@@@ocaml.text @@ -685,6 +685,8 @@ sig ('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 val embed_string : (string, 'c) Conversion.embedding @@ -692,6 +694,8 @@ sig ('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 val readback_context : diff --git a/src/API.ml b/src/API.ml index 99310c734..fad808267 100644 --- a/src/API.ml +++ b/src/API.ml @@ -1066,19 +1066,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 afa6ed9ac..5f63734dd 100644 --- a/src/API.mli +++ b/src/API.mli @@ -1136,6 +1136,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 @@ -1143,6 +1145,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 e7ddbf63b..24cc9e3bc 100644 --- a/src/builtin.ml +++ b/src/builtin.ml @@ -1379,8 +1379,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 @@ -1388,8 +1386,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 43282d08c59883f8045c687c2db39d502346d97d Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Apr 2020 17:31:52 +0200 Subject: [PATCH 6/6] enter ocaml-elpi --- ocaml-elpi/document_ocaml_ast_for_elpi.ml | 23 + ocaml-elpi/dune | 31 + ocaml-elpi/dune-project | 3 + ocaml-elpi/main_ocaml_elpi_rewriter.ml | 153 +++ ocaml-elpi/ocaml-elpi.opam | 0 ocaml-elpi/ocaml_ast.elpi | 607 +++++++++ ocaml-elpi/ocaml_ast_for_elpi.ml | 1090 +++++++++++++++++ ocaml-elpi/tests/dune | 27 + ocaml-elpi/tests/dune.inc | 15 + ocaml-elpi/tests/gen_dune.ml | 35 + ocaml-elpi/tests/pp.ml | 1 + ocaml-elpi/tests/test_swap.elpi | 3 + ocaml-elpi/tests/test_swap.expected.ml | 1 + ocaml-elpi/tests/test_swap.ml | 1 + ocaml-elpi/vendored/README.md | 1 + ocaml-elpi/vendored/ppx_show-0.2.0/.gitignore | 5 + ocaml-elpi/vendored/ppx_show-0.2.0/ChangeLog | 7 + ocaml-elpi/vendored/ppx_show-0.2.0/LICENSE | 29 + ocaml-elpi/vendored/ppx_show-0.2.0/Makefile | 38 + ocaml-elpi/vendored/ppx_show-0.2.0/README.md | 7 + .../vendored/ppx_show-0.2.0/dune-project | 20 + .../vendored/ppx_show-0.2.0/runtime/dune | 3 + .../runtime/ppx_show_runtime.ml | 29 + .../runtime/ppx_show_runtime.mli | 17 + ocaml-elpi/vendored/ppx_show-0.2.0/src/dune | 7 + .../vendored/ppx_show-0.2.0/src/ppx_show.ml | 413 +++++++ .../vendored/ppx_show-0.2.0/src/tools.ml | 117 ++ .../vendored/ppx_show-0.2.0/src/tools.mli | 46 + .../vendored/ppx_show-0.2.0/tests/show/dune | 5 + .../ppx_show-0.2.0/tests/show/show.ml | 111 ++ 30 files changed, 2845 insertions(+) create mode 100644 ocaml-elpi/document_ocaml_ast_for_elpi.ml create mode 100644 ocaml-elpi/dune create mode 100644 ocaml-elpi/dune-project create mode 100644 ocaml-elpi/main_ocaml_elpi_rewriter.ml create mode 100644 ocaml-elpi/ocaml-elpi.opam create mode 100644 ocaml-elpi/ocaml_ast.elpi create mode 100644 ocaml-elpi/ocaml_ast_for_elpi.ml create mode 100644 ocaml-elpi/tests/dune create mode 100644 ocaml-elpi/tests/dune.inc create mode 100644 ocaml-elpi/tests/gen_dune.ml create mode 100644 ocaml-elpi/tests/pp.ml create mode 100644 ocaml-elpi/tests/test_swap.elpi create mode 100644 ocaml-elpi/tests/test_swap.expected.ml create mode 100644 ocaml-elpi/tests/test_swap.ml create mode 100644 ocaml-elpi/vendored/README.md create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/.gitignore create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/ChangeLog create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/LICENSE create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/Makefile create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/README.md create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/dune-project create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/runtime/dune create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.ml create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.mli create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/src/dune create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/src/ppx_show.ml create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.ml create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.mli create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/dune create mode 100644 ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/show.ml diff --git a/ocaml-elpi/document_ocaml_ast_for_elpi.ml b/ocaml-elpi/document_ocaml_ast_for_elpi.ml new file mode 100644 index 000000000..b50485735 --- /dev/null +++ b/ocaml-elpi/document_ocaml_ast_for_elpi.ml @@ -0,0 +1,23 @@ +(* This simple file documents is Sys.argv.(1) the Elpi description of OCaml's AST *) + +open Elpi.API + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) + (Ocaml_elpi_ppx.Ocaml_ast_for_elpi.parsetree_declaration) + +let main () = + let elpi, _ = Setup.init ~builtins:[builtin ; Elpi.Builtin.std_builtins] ~basedir:"." [] in + BuiltIn.document_file builtin; + flush_all (); + let program = Parse.program ~elpi [] in + let program = Compile.program ~elpi ~flags:Compile.default_flags [program] in + let query = + let open Query in + compile program (Ast.Loc.initial "ppx") @@ + Query { predicate = "true"; arguments = N } in + if Compile.static_check ~checker:Elpi.Builtin.(default_checker ()) query then exit 0 + else (Printf.eprintf "document_ocaml_ast: generated elpi code does not type check"; exit 1) +;; + +main () \ No newline at end of file diff --git a/ocaml-elpi/dune b/ocaml-elpi/dune new file mode 100644 index 000000000..8a55a6163 --- /dev/null +++ b/ocaml-elpi/dune @@ -0,0 +1,31 @@ + +(library + (name ocaml_elpi_ppx) + (public_name ocaml-elpi.ppx) + (libraries + ocaml-compiler-libs.shadow + ocaml-compiler-libs.common + compiler-libs.common + ocaml-migrate-parsetree + elpi ppxlib ppx_show.runtime) + (flags (:standard -open Ocaml_shadow -safe-string)) + (preprocess (pps ppx_show elpi.ppx)) + (modules ocaml_ast_for_elpi main_ocaml_elpi_rewriter) + (kind ppx_rewriter) + (optional) +) + +(rule + (target ocaml_ast.elpi) + (mode promote) + (action (run ./document_ocaml_ast_for_elpi.exe %{target})) ) + +(executable + (name document_ocaml_ast_for_elpi) + (modules document_ocaml_ast_for_elpi) + (optional) + (libraries ocaml-elpi.ppx)) + +(env + (dev + (flags (:standard -warn-error -A)))) diff --git a/ocaml-elpi/dune-project b/ocaml-elpi/dune-project new file mode 100644 index 000000000..226f06275 --- /dev/null +++ b/ocaml-elpi/dune-project @@ -0,0 +1,3 @@ +(lang dune 2.0) +(name ocaml-elpi) +(allow_approximate_merlin) diff --git a/ocaml-elpi/main_ocaml_elpi_rewriter.ml b/ocaml-elpi/main_ocaml_elpi_rewriter.ml new file mode 100644 index 000000000..84f966127 --- /dev/null +++ b/ocaml-elpi/main_ocaml_elpi_rewriter.ml @@ -0,0 +1,153 @@ +open Elpi.API +open Ocaml_ast_for_elpi + +let builtin = let open BuiltIn in + declare ~file_name:(Sys.argv.(1)) parsetree_declaration + +let mapper = String.concat "\n" (Elpi.Builtin.PPX.mapper_src :: parsetree_mapper) + +let program_src = ref "" +let typecheck = ref false +let debug = ref (try ignore(Sys.getenv "DEBUG"); true with Not_found -> false) + +let map_structure s = + if !program_src = "" then begin + Printf.eprintf {| +ocaml-elpi.ppx: no program specified. Supported options: + --cookie 'program=\"some_file.elpi\"' source code of the rewriter (mandatory) + --cookie typecheck=1 typcheck the program + --cookie debug=1 print debug trace (also env DEBUG=1) +|}; + exit 1; + end; + let elpi, _ = Setup.init ~builtins:[builtin;Elpi.Builtin.std_builtins] ~basedir:"." [] in + BuiltIn.document_file builtin; + if !debug then + Setup.trace ["-trace-on";"tty";"stderr";"-trace-only";"user";"-trace-only-pred";"map";"-trace-at";"run";"1";"99999"]; + let program = Parse.program ~elpi [!program_src] in + let mapper = Parse.program_from_stream ~elpi (Ast.Loc.initial "mapper") (Stream.of_string mapper) in + let program = Compile.program ~elpi ~flags:Compile.default_flags [program;mapper] in + let query = + let open Query in + let open ContextualConversion in + compile program (Ast.Loc.initial "ppx") @@ + Query { predicate = "map.structure"; arguments = D(!< structure,s,(Q(!< structure,"Result",N))) } in + if !typecheck then begin + if not @@ Compile.static_check ~checker:Elpi.Builtin.(default_checker ()) query then begin + exit 1 + end + end; + let exe = Compile.optimize query in + match Execute.once exe with + | Execute.Success { output = (s,_); _ } -> s + | _ -> + Printf.eprintf "elpi.ocaml_ppx: rewriter %s failed" !program_src; + exit 1 +;; + +let erase_loc = + let open Ppxlib in + (* let open Ppxlib.Ast_pattern in *) + object + inherit [State.t] Ast_traverse.fold_map + method! location _ (st : State.t) = Ocaml_ast_for_elpi.dummy_location, st + end +;; + +let expression_quotation ~depth state _loc s = + let e = Ppxlib.Parse.expression (Lexing.from_string s) in + let e, state = erase_loc#expression e state in + let state, x, gls = (ContextualConversion.(!<) expression).Conversion.embed ~depth state e in + assert(gls = []); + state, x + +let () = Quotation.register_named_quotation ~name:"expr" expression_quotation +let () = Quotation.set_default_quotation expression_quotation + +let pattern_quotation ~depth state _loc s = + let e = Ppxlib.Parse.pattern (Lexing.from_string s) in + let e, state = erase_loc#pattern e state in + let state, x, gls = (ContextualConversion.(!<) pattern).Conversion.embed ~depth state e in + assert(gls = []); + state, x + +let () = Quotation.register_named_quotation ~name:"pat" pattern_quotation + +let type_quotation ~depth state _loc s = + let e = Ppxlib.Parse.core_type (Lexing.from_string s) in + let e, state = erase_loc#core_type e state in + let state, x, gls = (ContextualConversion.(!<) core_type).Conversion.embed ~depth state e in + assert(gls = []); + state, x + +let () = Quotation.register_named_quotation ~name:"type" type_quotation + +let stri_quotation ~depth state _loc s = + let e = Ppxlib.Parse.toplevel_phrase (Lexing.from_string s) in + match e with + | Ptop_def [e] -> + let e, state = erase_loc#structure_item e state in + let state, x, gls = (ContextualConversion.(!<) structure_item).Conversion.embed ~depth state e in + assert(gls = []); + state, x + | Ptop_def _ -> + Ppxlib.Location.raise_errorf "{{:stri ...}} takes only one signature item, use {{:str ...}} for more" + | Ptop_dir { pdir_loc = loc; _ } -> + Ppxlib.Location.raise_errorf ~loc "{{:stri ...}} cannot contain a #directive" + +let () = Quotation.register_named_quotation ~name:"stri" stri_quotation + +let sigi_quotation ~depth state _loc s = + let e = Ppxlib.Parse.interface (Lexing.from_string s) in + match e with + | [e] -> + let e, state = erase_loc#signature_item e state in + let state, x, gls = (ContextualConversion.(!<) signature_item).Conversion.embed ~depth state e in + assert(gls = []); + state, x + | _ -> + Ppxlib.Location.raise_errorf "{{:sigi ...}} takes only one signature item, use {{:sig ...}} for more" + +let () = Quotation.register_named_quotation ~name:"sigi" stri_quotation + +let structure_quotation ~depth state _loc s = + let e = Ppxlib.Parse.implementation (Lexing.from_string s) in + let e, state = erase_loc#structure e state in + let state, x, gls = (ContextualConversion.(!<) structure).Conversion.embed ~depth state e in + assert(gls = []); + state, x + +let () = Quotation.register_named_quotation ~name:"str" structure_quotation + +let signature_quotation ~depth state _loc s = + let e = Ppxlib.Parse.interface (Lexing.from_string s) in + let e, state = erase_loc#signature e state in + let state, x, gls = (ContextualConversion.(!<) signature).Conversion.embed ~depth state e in + assert(gls = []); + state, x + +let () = Quotation.register_named_quotation ~name:"sig" signature_quotation + + +open Ppxlib + +let arg_program t = + match Driver.Cookies.get t "program" Ast_pattern.(estring __) with + | Some p -> program_src := p + | _ -> () + +let arg_typecheck t = + match Driver.Cookies.get t "typecheck" Ast_pattern.(__) with + | Some _ -> typecheck := true + | _ -> () + +let arg_debug t = + match Driver.Cookies.get t "debug" Ast_pattern.(__) with + | Some _ -> debug := true + | _ -> () + +let () = + Driver.Cookies.add_handler arg_program; + Driver.register_transformation + ~impl:map_structure + "elpi" \ No newline at end of file diff --git a/ocaml-elpi/ocaml-elpi.opam b/ocaml-elpi/ocaml-elpi.opam new file mode 100644 index 000000000..e69de29bb diff --git a/ocaml-elpi/ocaml_ast.elpi b/ocaml-elpi/ocaml_ast.elpi new file mode 100644 index 000000000..4ce9fb42e --- /dev/null +++ b/ocaml-elpi/ocaml_ast.elpi @@ -0,0 +1,607 @@ + + +% position +kind position type. +type position string -> int -> int -> int -> position. % position + +% location +kind location type. +type location position -> position -> bool -> location. % location + +typeabbrev location-stack (list location). % location_stack + +% loc +kind loc_ type -> type. +type loc A0 -> location -> loc_ A0. % loc + +% longident +kind longident type. +type lident string -> longident. % Lident +type ldot longident -> string -> longident. % Ldot +type lapply longident -> longident -> longident. % Lapply + +typeabbrev longident-loc (loc_ longident). % longident_loc + +% rec_flag +kind rec-flag type. +type nonrecursive rec-flag. % Nonrecursive +type recursive rec-flag. % Recursive + +% direction_flag +kind direction-flag type. +type upto direction-flag. % Upto +type downto direction-flag. % Downto + +% private_flag +kind private-flag type. +type private private-flag. % Private +type public private-flag. % Public + +% mutable_flag +kind mutable-flag type. +type immutable mutable-flag. % Immutable +type mutable mutable-flag. % Mutable + +% virtual_flag +kind virtual-flag type. +type virtual virtual-flag. % Virtual +type concrete virtual-flag. % Concrete + +% override_flag +kind override-flag type. +type override override-flag. % Override +type fresh override-flag. % Fresh + +% closed_flag +kind closed-flag type. +type closed_ closed-flag. % Closed +type open_ closed-flag. % Open + +typeabbrev label string. % label + +% arg_label +kind arg-label type. +type nolabel arg-label. % Nolabel +type labelled string -> arg-label. % Labelled +type optional string -> arg-label. % Optional + +% variance +kind variance type. +type covariant variance. % Covariant +type contravariant variance. % Contravariant +type invariant variance. % Invariant + +% constant +kind constant_ type. +type pconst-integer string -> option char -> constant_. % Pconst_integer +type pconst-char char -> constant_. % Pconst_char +type pconst-string string -> option string -> constant_. % Pconst_string +type pconst-float string -> option char -> constant_. % Pconst_float + +% attribute +kind attribute type. +type attribute loc_ string -> payload -> location -> + attribute. % attribute + +typeabbrev extension (pair (loc_ string) payload). % extension + +typeabbrev attributes (list attribute). % attributes + +% payload +kind payload type. +type pstr structure -> payload. % PStr +type psig signature -> payload. % PSig +type ptyp core-type -> payload. % PTyp +type ppat pattern -> option expression -> payload. % PPat + +% core_type +kind core-type type. +type core-type core-type-desc -> location -> location-stack -> + attributes -> core-type. % core_type + +% core_type_desc +kind core-type-desc type. +type ptyp-any core-type-desc. % Ptyp_any +type ptyp-var string -> core-type-desc. % Ptyp_var +type ptyp-arrow arg-label -> core-type -> core-type -> + core-type-desc. % Ptyp_arrow +type ptyp-tuple list core-type -> core-type-desc. % Ptyp_tuple +type ptyp-constr longident-loc -> list core-type -> + core-type-desc. % Ptyp_constr +type ptyp-object list object-field -> closed-flag -> + core-type-desc. % Ptyp_object +type ptyp-class longident-loc -> list core-type -> + core-type-desc. % Ptyp_class +type ptyp-alias core-type -> string -> core-type-desc. % Ptyp_alias +type ptyp-variant list row-field -> closed-flag -> option (list label) -> + core-type-desc. % Ptyp_variant +type ptyp-poly list (loc_ string) -> core-type -> + core-type-desc. % Ptyp_poly +type ptyp-package package-type -> core-type-desc. % Ptyp_package +type ptyp-extension extension -> core-type-desc. % Ptyp_extension + +typeabbrev package-type (pair longident-loc (list (pair longident-loc core-type))). % package_type + +% row_field +kind row-field type. +type row-field row-field-desc -> location -> attributes -> + row-field. % row_field + +% row_field_desc +kind row-field-desc type. +type rtag loc_ label -> bool -> list core-type -> row-field-desc. % Rtag +type rinherit core-type -> row-field-desc. % Rinherit + +% object_field +kind object-field type. +type object-field object-field-desc -> location -> attributes -> + object-field. % object_field + +% object_field_desc +kind object-field-desc type. +type otag loc_ label -> core-type -> object-field-desc. % Otag +type oinherit core-type -> object-field-desc. % Oinherit + +% pattern +kind pattern type. +type pattern pattern-desc -> location -> location-stack -> attributes -> + pattern. % pattern + +% pattern_desc +kind pattern-desc type. +type ppat-any pattern-desc. % Ppat_any +type ppat-var loc_ string -> pattern-desc. % Ppat_var +type ppat-alias pattern -> loc_ string -> pattern-desc. % Ppat_alias +type ppat-constant constant_ -> pattern-desc. % Ppat_constant +type ppat-interval constant_ -> constant_ -> pattern-desc. % Ppat_interval +type ppat-tuple list pattern -> pattern-desc. % Ppat_tuple +type ppat-construct longident-loc -> option pattern -> + pattern-desc. % Ppat_construct +type ppat-variant label -> option pattern -> pattern-desc. % Ppat_variant +type ppat-record list (pair longident-loc pattern) -> closed-flag -> + pattern-desc. % Ppat_record +type ppat-array list pattern -> pattern-desc. % Ppat_array +type ppat-or pattern -> pattern -> pattern-desc. % Ppat_or +type ppat-constraint pattern -> core-type -> + pattern-desc. % Ppat_constraint +type ppat-type longident-loc -> pattern-desc. % Ppat_type +type ppat-lazy pattern -> pattern-desc. % Ppat_lazy +type ppat-unpack loc_ string -> pattern-desc. % Ppat_unpack +type ppat-exception pattern -> pattern-desc. % Ppat_exception +type ppat-extension extension -> pattern-desc. % Ppat_extension +type ppat-open longident-loc -> pattern -> pattern-desc. % Ppat_open + +% expression +kind expression type. +type expression expression-desc -> location -> location-stack -> + attributes -> expression. % expression + +% expression_desc +kind expression-desc type. +type pexp-ident longident-loc -> expression-desc. % Pexp_ident +type pexp-constant constant_ -> expression-desc. % Pexp_constant +type pexp-let rec-flag -> list value-binding -> expression -> + expression-desc. % Pexp_let +type pexp-function list case -> expression-desc. % Pexp_function +type pexp-fun arg-label -> option expression -> pattern -> expression -> + expression-desc. % Pexp_fun +type pexp-apply expression -> list (pair arg-label expression) -> + expression-desc. % Pexp_apply +type pexp-match expression -> list case -> expression-desc. % Pexp_match +type pexp-try expression -> list case -> expression-desc. % Pexp_try +type pexp-tuple list expression -> expression-desc. % Pexp_tuple +type pexp-construct longident-loc -> option expression -> + expression-desc. % Pexp_construct +type pexp-variant label -> option expression -> + expression-desc. % Pexp_variant +type pexp-record list (pair longident-loc expression) -> + option expression -> expression-desc. % Pexp_record +type pexp-field expression -> longident-loc -> + expression-desc. % Pexp_field +type pexp-setfield expression -> longident-loc -> expression -> + expression-desc. % Pexp_setfield +type pexp-array list expression -> expression-desc. % Pexp_array +type pexp-ifthenelse expression -> expression -> option expression -> + expression-desc. % Pexp_ifthenelse +type pexp-sequence expression -> expression -> + expression-desc. % Pexp_sequence +type pexp-while expression -> expression -> expression-desc. % Pexp_while +type pexp-for pattern -> expression -> expression -> direction-flag -> + expression -> expression-desc. % Pexp_for +type pexp-constraint expression -> core-type -> + expression-desc. % Pexp_constraint +type pexp-coerce expression -> option core-type -> core-type -> + expression-desc. % Pexp_coerce +type pexp-send expression -> loc_ label -> expression-desc. % Pexp_send +type pexp-new longident-loc -> expression-desc. % Pexp_new +type pexp-setinstvar loc_ label -> expression -> + expression-desc. % Pexp_setinstvar +type pexp-override list (pair (loc_ label) expression) -> + expression-desc. % Pexp_override +type pexp-letmodule loc_ string -> module-expr -> expression -> + expression-desc. % Pexp_letmodule +type pexp-letexception extension-constructor -> expression -> + expression-desc. % Pexp_letexception +type pexp-assert expression -> expression-desc. % Pexp_assert +type pexp-lazy expression -> expression-desc. % Pexp_lazy +type pexp-poly expression -> option core-type -> + expression-desc. % Pexp_poly +type pexp-object class-structure -> expression-desc. % Pexp_object +type pexp-newtype loc_ string -> expression -> + expression-desc. % Pexp_newtype +type pexp-pack module-expr -> expression-desc. % Pexp_pack +type pexp-open open-declaration -> expression -> + expression-desc. % Pexp_open +type pexp-letop letop -> expression-desc. % Pexp_letop +type pexp-extension extension -> expression-desc. % Pexp_extension +type pexp-unreachable expression-desc. % Pexp_unreachable + +% case +kind case type. +type case pattern -> option expression -> expression -> case. % case + +% letop +kind letop type. +type letop binding-op -> list binding-op -> expression -> letop. % letop + +% binding_op +kind binding-op type. +type binding-op loc_ string -> pattern -> expression -> location -> + binding-op. % binding_op + +% value_description +kind value-description type. +type value-description loc_ string -> core-type -> list string -> + attributes -> location -> + value-description. % value_description + +% type_declaration +kind type-declaration type. +type type-declaration loc_ string -> list (pair core-type variance) -> + list (triple core-type core-type location) -> + type-kind -> private-flag -> option core-type -> + attributes -> location -> + type-declaration. % type_declaration + +% type_kind +kind type-kind type. +type ptype-abstract type-kind. % Ptype_abstract +type ptype-variant list constructor-declaration -> + type-kind. % Ptype_variant +type ptype-record list label-declaration -> type-kind. % Ptype_record +type ptype-open type-kind. % Ptype_open + +% label_declaration +kind label-declaration type. +type label-declaration loc_ string -> mutable-flag -> core-type -> + location -> attributes -> + label-declaration. % label_declaration + +% constructor_declaration +kind constructor-declaration type. +type constructor-declaration loc_ string -> constructor-arguments -> + option core-type -> location -> attributes -> + constructor-declaration. % constructor_declaration + +% constructor_arguments +kind constructor-arguments type. +type pcstr-tuple list core-type -> constructor-arguments. % Pcstr_tuple +type pcstr-record list label-declaration -> + constructor-arguments. % Pcstr_record + +% type_extension +kind type-extension type. +type type-extension longident-loc -> list (pair core-type variance) -> + list extension-constructor -> private-flag -> + location -> attributes -> + type-extension. % type_extension + +% extension_constructor +kind extension-constructor type. +type extension-constructor loc_ string -> extension-constructor-kind -> + location -> attributes -> + extension-constructor. % extension_constructor + +% type_exception +kind type-exception type. +type type-exception extension-constructor -> location -> attributes -> + type-exception. % type_exception + +% extension_constructor_kind +kind extension-constructor-kind type. +type pext-decl constructor-arguments -> option core-type -> + extension-constructor-kind. % Pext_decl +type pext-rebind longident-loc -> + extension-constructor-kind. % Pext_rebind + +% class_type +kind class-type type. +type class-type class-type-desc -> location -> attributes -> + class-type. % class_type + +% class_type_desc +kind class-type-desc type. +type pcty-constr longident-loc -> list core-type -> + class-type-desc. % Pcty_constr +type pcty-signature class-signature -> class-type-desc. % Pcty_signature +type pcty-arrow arg-label -> core-type -> class-type -> + class-type-desc. % Pcty_arrow +type pcty-extension extension -> class-type-desc. % Pcty_extension +type pcty-open open-description -> class-type -> + class-type-desc. % Pcty_open + +% class_signature +kind class-signature type. +type class-signature core-type -> list class-type-field -> + class-signature. % class_signature + +% class_type_field +kind class-type-field type. +type class-type-field class-type-field-desc -> location -> attributes -> + class-type-field. % class_type_field + +% class_type_field_desc +kind class-type-field-desc type. +type pctf-inherit class-type -> class-type-field-desc. % Pctf_inherit +type pctf-val quadruple (loc_ label) mutable-flag virtual-flag core-type -> + class-type-field-desc. % Pctf_val +type pctf-method quadruple (loc_ label) private-flag virtual-flag core-type -> + class-type-field-desc. % Pctf_method +type pctf-constraint pair core-type core-type -> + class-type-field-desc. % Pctf_constraint +type pctf-attribute attribute -> class-type-field-desc. % Pctf_attribute +type pctf-extension extension -> class-type-field-desc. % Pctf_extension + +% class_infos +kind class-infos type -> type. +type class-infos virtual-flag -> list (pair core-type variance) -> + loc_ string -> A0 -> location -> attributes -> + class-infos A0. % class_infos + +typeabbrev class-description (class-infos class-type). % class_description + +typeabbrev class-type-declaration (class-infos class-type). % class_type_declaration + +% class_expr +kind class-expr type. +type class-expr class-expr-desc -> location -> attributes -> + class-expr. % class_expr + +% class_expr_desc +kind class-expr-desc type. +type pcl-constr longident-loc -> list core-type -> + class-expr-desc. % Pcl_constr +type pcl-structure class-structure -> class-expr-desc. % Pcl_structure +type pcl-fun arg-label -> option expression -> pattern -> class-expr -> + class-expr-desc. % Pcl_fun +type pcl-apply class-expr -> list (pair arg-label expression) -> + class-expr-desc. % Pcl_apply +type pcl-let rec-flag -> list value-binding -> class-expr -> + class-expr-desc. % Pcl_let +type pcl-constraint class-expr -> class-type -> + class-expr-desc. % Pcl_constraint +type pcl-extension extension -> class-expr-desc. % Pcl_extension +type pcl-open open-description -> class-expr -> + class-expr-desc. % Pcl_open + +% class_structure +kind class-structure type. +type class-structure pattern -> list class-field -> + class-structure. % class_structure + +% class_field +kind class-field type. +type class-field class-field-desc -> location -> attributes -> + class-field. % class_field + +% class_field_desc +kind class-field-desc type. +type pcf-inherit override-flag -> class-expr -> option (loc_ string) -> + class-field-desc. % Pcf_inherit +type pcf-val triple (loc_ label) mutable-flag class-field-kind -> + class-field-desc. % Pcf_val +type pcf-method triple (loc_ label) private-flag class-field-kind -> + class-field-desc. % Pcf_method +type pcf-constraint pair core-type core-type -> + class-field-desc. % Pcf_constraint +type pcf-initializer expression -> class-field-desc. % Pcf_initializer +type pcf-attribute attribute -> class-field-desc. % Pcf_attribute +type pcf-extension extension -> class-field-desc. % Pcf_extension + +% class_field_kind +kind class-field-kind type. +type cfk-virtual core-type -> class-field-kind. % Cfk_virtual +type cfk-concrete override-flag -> expression -> + class-field-kind. % Cfk_concrete + +typeabbrev class-declaration (class-infos class-expr). % class_declaration + +% module_type +kind module-type type. +type module-type module-type-desc -> location -> attributes -> + module-type. % module_type + +% module_type_desc +kind module-type-desc type. +type pmty-ident longident-loc -> module-type-desc. % Pmty_ident +type pmty-signature signature -> module-type-desc. % Pmty_signature +type pmty-functor loc_ string -> option module-type -> module-type -> + module-type-desc. % Pmty_functor +type pmty-with module-type -> list with-constraint -> + module-type-desc. % Pmty_with +type pmty-typeof module-expr -> module-type-desc. % Pmty_typeof +type pmty-extension extension -> module-type-desc. % Pmty_extension +type pmty-alias longident-loc -> module-type-desc. % Pmty_alias + +typeabbrev signature (list signature-item). % signature + +% signature_item +kind signature-item type. +type signature-item signature-item-desc -> location -> + signature-item. % signature_item + +% signature_item_desc +kind signature-item-desc type. +type psig-value value-description -> signature-item-desc. % Psig_value +type psig-type rec-flag -> list type-declaration -> + signature-item-desc. % Psig_type +type psig-typesubst list type-declaration -> + signature-item-desc. % Psig_typesubst +type psig-typext type-extension -> signature-item-desc. % Psig_typext +type psig-exception type-exception -> + signature-item-desc. % Psig_exception +type psig-module module-declaration -> signature-item-desc. % Psig_module +type psig-modsubst module-substitution -> + signature-item-desc. % Psig_modsubst +type psig-recmodule list module-declaration -> + signature-item-desc. % Psig_recmodule +type psig-modtype module-type-declaration -> + signature-item-desc. % Psig_modtype +type psig-open open-description -> signature-item-desc. % Psig_open +type psig-include include-description -> + signature-item-desc. % Psig_include +type psig-class list class-description -> + signature-item-desc. % Psig_class +type psig-class-type list class-type-declaration -> + signature-item-desc. % Psig_class_type +type psig-attribute attribute -> signature-item-desc. % Psig_attribute +type psig-extension extension -> attributes -> + signature-item-desc. % Psig_extension + +% module_declaration +kind module-declaration type. +type module-declaration loc_ string -> module-type -> attributes -> + location -> + module-declaration. % module_declaration + +% module_substitution +kind module-substitution type. +type module-substitution loc_ string -> longident-loc -> attributes -> + location -> + module-substitution. % module_substitution + +% module_type_declaration +kind module-type-declaration type. +type module-type-declaration loc_ string -> option module-type -> + attributes -> location -> + module-type-declaration. % module_type_declaration + +% open_infos +kind open-infos type -> type. +type open-infos A0 -> override-flag -> location -> attributes -> + open-infos A0. % open_infos + +typeabbrev open-description (open-infos longident-loc). % open_description + +typeabbrev open-declaration (open-infos module-expr). % open_declaration + +% include_infos +kind include-infos type -> type. +type include-infos A0 -> location -> attributes -> + include-infos A0. % include_infos + +typeabbrev include-description (include-infos module-type). % include_description + +typeabbrev include-declaration (include-infos module-expr). % include_declaration + +% with_constraint +kind with-constraint type. +type pwith-type longident-loc -> type-declaration -> + with-constraint. % Pwith_type +type pwith-module longident-loc -> longident-loc -> + with-constraint. % Pwith_module +type pwith-typesubst longident-loc -> type-declaration -> + with-constraint. % Pwith_typesubst +type pwith-modsubst longident-loc -> longident-loc -> + with-constraint. % Pwith_modsubst + +% module_expr +kind module-expr type. +type module-expr module-expr-desc -> location -> attributes -> + module-expr. % module_expr + +% module_expr_desc +kind module-expr-desc type. +type pmod-ident longident-loc -> module-expr-desc. % Pmod_ident +type pmod-structure structure -> module-expr-desc. % Pmod_structure +type pmod-functor loc_ string -> option module-type -> module-expr -> + module-expr-desc. % Pmod_functor +type pmod-apply module-expr -> module-expr -> + module-expr-desc. % Pmod_apply +type pmod-constraint module-expr -> module-type -> + module-expr-desc. % Pmod_constraint +type pmod-unpack expression -> module-expr-desc. % Pmod_unpack +type pmod-extension extension -> module-expr-desc. % Pmod_extension + +typeabbrev structure (list structure-item). % structure + +% structure_item +kind structure-item type. +type structure-item structure-item-desc -> location -> + structure-item. % structure_item + +% structure_item_desc +kind structure-item-desc type. +type pstr-eval expression -> attributes -> + structure-item-desc. % Pstr_eval +type pstr-value rec-flag -> list value-binding -> + structure-item-desc. % Pstr_value +type pstr-primitive value-description -> + structure-item-desc. % Pstr_primitive +type pstr-type rec-flag -> list type-declaration -> + structure-item-desc. % Pstr_type +type pstr-typext type-extension -> structure-item-desc. % Pstr_typext +type pstr-exception type-exception -> + structure-item-desc. % Pstr_exception +type pstr-module module-binding -> structure-item-desc. % Pstr_module +type pstr-recmodule list module-binding -> + structure-item-desc. % Pstr_recmodule +type pstr-modtype module-type-declaration -> + structure-item-desc. % Pstr_modtype +type pstr-open open-declaration -> structure-item-desc. % Pstr_open +type pstr-class list class-declaration -> + structure-item-desc. % Pstr_class +type pstr-class-type list class-type-declaration -> + structure-item-desc. % Pstr_class_type +type pstr-include include-declaration -> + structure-item-desc. % Pstr_include +type pstr-attribute attribute -> structure-item-desc. % Pstr_attribute +type pstr-extension extension -> attributes -> + structure-item-desc. % Pstr_extension + +% value_binding +kind value-binding type. +type value-binding pattern -> expression -> attributes -> location -> + value-binding. % value_binding + +% module_binding +kind module-binding type. +type module-binding loc_ string -> module-expr -> attributes -> + location -> module-binding. % module_binding + +% toplevel_phrase +kind toplevel-phrase type. +type ptop-def structure -> toplevel-phrase. % Ptop_def +type ptop-dir toplevel-directive -> toplevel-phrase. % Ptop_dir + +% toplevel_directive +kind toplevel-directive type. +type toplevel-directive loc_ string -> option directive-argument -> + location -> + toplevel-directive. % toplevel_directive + +% directive_argument +kind directive-argument type. +type directive-argument directive-argument-desc -> location -> + directive-argument. % directive_argument + +% directive_argument_desc +kind directive-argument-desc type. +type pdir-string string -> directive-argument-desc. % Pdir_string +type pdir-int string -> option char -> directive-argument-desc. % Pdir_int +type pdir-ident longident -> directive-argument-desc. % Pdir_ident +type pdir-bool bool -> directive-argument-desc. % Pdir_bool + + + + diff --git a/ocaml-elpi/ocaml_ast_for_elpi.ml b/ocaml-elpi/ocaml_ast_for_elpi.ml new file mode 100644 index 000000000..537f34b58 --- /dev/null +++ b/ocaml-elpi/ocaml_ast_for_elpi.ml @@ -0,0 +1,1090 @@ +let parsetree_declaration = ref [] +let parsetree_mapper = ref [] +open Ppxlib_ast.Import_for_core + +let elpi_loc_of_location loc = + let open Location in + let open Lexing in + { + Elpi.API.Ast.Loc.source_name = loc.loc_end.pos_fname; + source_start = loc.loc_end.pos_cnum; + source_stop = loc.loc_end.pos_cnum; + line = loc.loc_end.pos_lnum; + line_starts_at = loc.loc_end.pos_bol; + } + +let dummy_position = + let open Lexing in + { + pos_fname = "$elpi"; + pos_lnum = 0; + pos_bol = 0; + pos_cnum = 0; + } + +let dummy_location = + let open Location in + { + loc_start = dummy_position; + loc_end = dummy_position; + loc_ghost = false + } + +let maybe_override_embed default = fun ~depth h c st e -> + let open Parsetree in + match e with + | ({ Location.txt = ("e"|"p"|"t"|"m"|"i"); _ }, PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Parsetree.Pexp_constant (Pconst_string(s,_)); pexp_loc = loc; _ },[]) ; _}]) -> + let loc = elpi_loc_of_location loc in + let st, x = Elpi.API.Quotation.lp ~depth st loc s in + st, x, [] + | e -> default ~depth h c st e + +let maybe_override_embed2 default = fun ~depth h c st e a -> + let open Parsetree in + match e with + | ({ Location.txt = ("e"|"p"|"t"|"m"|"i"); _ }, PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Parsetree.Pexp_constant (Pconst_string(s,_)); pexp_loc = loc; _ },[]) ; _}]) -> + let loc = elpi_loc_of_location loc in + let st, x = Elpi.API.Quotation.lp ~depth st loc s in + st, x, [] + | _ -> default ~depth h c st e a + +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Definition of the OCaml AST *) + + +(* This file is obtained by: + + - copying a subset of the corresponding ast_xxx.ml file from migrate-parsetree + (sub-modules Asttypes and Parsetree) + - adding the type definitions for position, location, loc and longident + - flattening all the modules + - removing Asttypes.constant (unused and conflicts with Parsetree.constant) + - renaming a few types: + - - Location.t -> location + - - Longident.t -> longident + - adding a type longident_loc = longident loc and replacing all the occurences of the + latter by the former. This is so that we can override iteration an the level of a + longident loc + - replacing all the (*IF_CURRENT = Foo.bar*) by: = Foo.bar + - removing the extra values at the end of the file + - replacing app [type ...] by [and ...] to make everything one recursive block + - adding [@@deriving_inline traverse][@@@end] at the end +*) + +(* Source code locations (ranges of positions), used in parsetree. *) + +type position = Lexing.position = + { pos_fname : string + ; pos_lnum : int + ; pos_bol : int + ; pos_cnum : int + } + +and location = Location.t = { + loc_start: position; + loc_end: position; + loc_ghost: bool; +} [@@elpi.embed fun default ~depth h c st start end_ ghost -> + if ghost = false && start = dummy_position && end_ = dummy_position then + let st, v = Elpi.API.FlexibleData.Elpi.make st in + st, Elpi.API.RawData.mkUnifVar v ~args: [] st, [] + else + default ~depth h c st start end_ ghost ] + [@@elpi.default_constructor_readback fun default ~depth h c st t -> + match Elpi.API.RawData.look ~depth t with + | Elpi.API.RawData.UnifVar _ -> st, dummy_location, [] + | _ -> default ~depth h c st t] + +and location_stack = location list + +(* Note on the use of Lexing.position in this module. + If [pos_fname = ""], then use [!input_name] instead. + If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and + re-parse the file to get the line and character numbers. + Else all fields are correct. + +*) +and 'a loc = 'a Location.loc = { + txt : 'a; + loc : location; +} +[@@elpi.type_code "loc_"] + +(* Long identifiers, used in parsetree. *) + +and longident = Longident.t = + Lident of string + | Ldot of longident * string + | Lapply of longident * longident + +and longident_loc = longident loc + +(** Auxiliary AST types used by parsetree and typedtree. *) + +and rec_flag = Asttypes.rec_flag = Nonrecursive | Recursive + +and direction_flag = Asttypes.direction_flag = Upto | Downto + +(* Order matters, used in polymorphic comparison *) +and private_flag = Asttypes.private_flag = Private | Public + +and mutable_flag = Asttypes.mutable_flag = Immutable | Mutable + +and virtual_flag = Asttypes.virtual_flag = Virtual | Concrete + +and override_flag = Asttypes.override_flag = Override | Fresh + +and closed_flag = Asttypes.closed_flag = Closed [@elpi.code "closed_"] | Open [@elpi.code "open_"] + +and label = string + +and arg_label = Asttypes.arg_label = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) + +and variance = Asttypes.variance = + | Covariant + | Contravariant + | Invariant + +(** Abstract syntax tree produced by parsing *) + +and constant = Parsetree.constant = + Pconst_integer of string * char option + (* 3 3l 3L 3n + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes except 'l', 'L' and 'n' are rejected by the typechecker + *) + | Pconst_char of char + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option + (* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) +[@@elpi.type_code "constant_"] (* silly bug in Elpi, constant is also a builtin *) +(** {1 Extension points} *) + +and attribute = Parsetree.attribute = + { attr_name : string loc; + attr_payload : payload; + attr_loc : location; + } +(* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. +*) + +and extension = string loc * payload +(* [%id ARG] + [%%id ARG] + + Sub-language placeholder -- rejected by the typechecker. +*) + +and attributes = attribute list + +and payload = Parsetree.payload = + | PStr of structure + | PSig of signature (* : SIG *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option (* ? P or ? P when E *) + +(** {1 Core language} *) + +(* Type expressions *) + +and core_type = Parsetree.core_type = + { + ptyp_desc: core_type_desc; + ptyp_loc: location; + ptyp_loc_stack: location_stack; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and core_type_desc = Parsetree.core_type_desc = + | Ptyp_any + (* _ *) + | Ptyp_var of string + (* 'a *) + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of longident_loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of longident_loc * core_type list + (* #tconstr + T #tconstr + (T1, ..., Tn) #tconstr + *) + | Ptyp_alias of core_type * string + (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string loc list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + + | Ptyp_package of package_type + (* (module S) *) + | Ptyp_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + +and package_type = longident_loc * (longident_loc * core_type) list + (* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) +*) + +and row_field = Parsetree.row_field = + { prf_desc : row_field_desc; + prf_loc : location; + prf_attributes : attributes; + } + +and row_field_desc = Parsetree.row_field_desc = + | Rtag of label loc * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type + (* [ T ] *) + +and object_field = Parsetree.object_field = + { pof_desc : object_field_desc; + pof_loc : location; + pof_attributes : attributes; + } + +and object_field_desc = Parsetree.object_field_desc = + | Otag of label loc * core_type + | Oinherit of core_type + +(* Patterns *) + +and pattern = Parsetree.pattern = + { + ppat_desc: pattern_desc; + ppat_loc: location; + ppat_loc_stack: location_stack; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and pattern_desc = Parsetree.pattern_desc = + | Ppat_any + (* _ *) + | Ppat_var of string loc + (* x *) + | Ppat_alias of pattern * string loc + (* P as 'a *) + | Ppat_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of longident_loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (longident_loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list + (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern + (* P1 | P2 *) + | Ppat_constraint of pattern * core_type + (* (P : T) *) + | Ppat_type of longident_loc + (* #tconst *) + | Ppat_lazy of pattern + (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern + (* exception P *) + | Ppat_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + | Ppat_open of longident_loc * pattern + (* M.(P) *) + +(* Value expressions *) + +and expression = Parsetree.expression = + { + pexp_desc: expression_desc; + pexp_loc: location; + pexp_loc_stack: location_stack; + pexp_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and expression_desc = Parsetree.expression_desc = + | Pexp_ident of longident_loc + (* x + M.x + *) + | Pexp_constant of constant + (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list + (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * case list + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * case list + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of longident_loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (longident_loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 + *) + | Pexp_field of expression * longident_loc + (* E.l *) + | Pexp_setfield of expression * longident_loc * expression + (* E1.l <- E2 *) + | Pexp_array of expression list + (* [| E1; ...; En |] *) + | Pexp_ifthenelse of expression * expression * expression option + (* if E1 then E2 else E3 *) + | Pexp_sequence of expression * expression + (* E1; E2 *) + | Pexp_while of expression * expression + (* while E1 do E2 done *) + | Pexp_for of + pattern * expression * expression * direction_flag * expression + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type + (* (E : T) *) + | Pexp_coerce of expression * core_type option * core_type + (* (E :> T) (None, T) + (E : T0 :> T) (Some T0, T) + *) + | Pexp_send of expression * label loc + (* E # m *) + | Pexp_new of longident_loc + (* new M.c *) + | Pexp_setinstvar of label loc * expression + (* x <- 2 *) + | Pexp_override of (label loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string loc * module_expr * expression + (* let module M = ME in E *) + | Pexp_letexception of extension_constructor * expression + (* let exception C in E *) + | Pexp_assert of expression + (* assert E + Note: "assert false" is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression + (* lazy E *) + | Pexp_poly of expression * core_type option + (* Used for method bodies. + + Can only be used as the expression under Cfk_concrete + for methods (not values). *) + | Pexp_object of class_structure + (* object ... end *) + | Pexp_newtype of string loc * expression + (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of open_declaration * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_letop of letop + (* let* P = E in E + let* P = E and* P = E in E *) + | Pexp_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + | Pexp_unreachable + (* . *) + +and case = Parsetree.case = (* (P -> E) or (P when E0 -> E) *) + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } + +and letop = Parsetree.letop = + { let_ : binding_op; + ands : binding_op list; + body : expression; + } + +and binding_op = Parsetree.binding_op = + { pbop_op : string loc; + pbop_pat : pattern; + pbop_exp : expression; + pbop_loc : location; + } + +(* Value descriptions *) + +and value_description = Parsetree.value_description = + { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_loc: location; + } + + (* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + +(* Type declarations *) + +and type_declaration = Parsetree.type_declaration = + { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * location) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: location; + } + + (* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) + +and type_kind = Parsetree.type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + | Ptype_record of label_declaration list + (* Invariant: non-empty list *) + | Ptype_open + +and label_declaration = Parsetree.label_declaration = + { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: location; + pld_attributes: attributes; (* l : T [@id1] [@id2] *) + } + +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. +*) + +and constructor_declaration = Parsetree.constructor_declaration = + { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: location; + pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) + } + +and constructor_arguments = Parsetree.constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + + (* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) + +and type_extension = Parsetree.type_extension = + { + ptyext_path: longident_loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: location; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + (* + type t += ... +*) + +and extension_constructor = Parsetree.extension_constructor = + { + pext_name: string loc; + pext_kind : extension_constructor_kind; + pext_loc : location; + pext_attributes: attributes; (* C of ... [@id1] [@id2] *) + } + +and type_exception = Parsetree.type_exception = + { ptyexn_constructor: extension_constructor; + ptyexn_loc: location; + ptyexn_attributes: attributes; + } + +and extension_constructor_kind = Parsetree.extension_constructor_kind = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of longident_loc + (* + | C = D + *) + +(** {1 Class language} *) + +(* Type expressions for the class language *) + +and class_type = Parsetree.class_type = + { + pcty_desc: class_type_desc; + pcty_loc: location; + pcty_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and class_type_desc = Parsetree.class_type_desc = + | Pcty_constr of longident_loc * core_type list + (* c + ['a1, ..., 'an] c *) + | Pcty_signature of class_signature + (* object ... end *) + | Pcty_arrow of arg_label * core_type * class_type + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l + *) + | Pcty_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + | Pcty_open of open_description * class_type + (* let open M in CT *) + +and class_signature = Parsetree.class_signature = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } +(* object('selfpat) ... end + object ... end (self = Ptyp_any) +*) + +and class_type_field = Parsetree.class_type_field = + { + pctf_desc: class_type_field_desc; + pctf_loc: location; + pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + +and class_type_field_desc = Parsetree.class_type_field_desc = + | Pctf_inherit of class_type + (* inherit CT *) + | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) + (* val x: T *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (* method x: T + + Note: T can be a Ptyp_poly. + *) + | Pctf_constraint of (core_type * core_type) + (* constraint T1 = T2 *) + | Pctf_attribute of attribute + (* [@@@id] *) + | Pctf_extension of extension [@elpi.embed maybe_override_embed ] + (* [%%id] *) + +and 'a class_infos = 'a Parsetree.class_infos = + { + pci_virt: virtual_flag; + pci_params: (core_type * variance) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: location; + pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* class c = ... + class ['a1,...,'an] c = ... + class virtual c = ... + + Also used for "class type" declaration. +*) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(* Value expressions for the class language *) + +and class_expr = Parsetree.class_expr = + { + pcl_desc: class_expr_desc; + pcl_loc: location; + pcl_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and class_expr_desc = Parsetree.class_expr_desc = + | Pcl_constr of longident_loc * core_type list + (* c + ['a1, ..., 'an] c *) + | Pcl_structure of class_structure + (* object ... end *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (* CE ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pcl_let of rec_flag * value_binding list * class_expr + (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) + *) + | Pcl_constraint of class_expr * class_type + (* (CE : CT) *) + | Pcl_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + | Pcl_open of open_description * class_expr + (* let open M in CE *) + + +and class_structure = Parsetree.class_structure = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } +(* object(selfpat) ... end + object ... end (self = Ppat_any) +*) + +and class_field = Parsetree.class_field = + { + pcf_desc: class_field_desc; + pcf_loc: location; + pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) + } + +and class_field_desc = Parsetree.class_field_desc = + | Pcf_inherit of override_flag * class_expr * string loc option + (* inherit CE + inherit CE as x + inherit! CE + inherit! CE as x + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (* val x = E + val virtual x: T + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (* method x = E (E can be a Pexp_poly) + method virtual x: T (T can be a Ptyp_poly) + *) + | Pcf_constraint of (core_type * core_type) + (* constraint T1 = T2 *) + | Pcf_initializer of expression + (* initializer E *) + | Pcf_attribute of attribute + (* [@@@id] *) + | Pcf_extension of extension [@elpi.embed maybe_override_embed ] + (* [%%id] *) + +and class_field_kind = Parsetree.class_field_kind = + | Cfk_virtual of core_type + | Cfk_concrete of override_flag * expression + +and class_declaration = class_expr class_infos + +(** {1 Module language} *) + +(* Type expressions for the module language *) + +and module_type = Parsetree.module_type = + { + pmty_desc: module_type_desc; + pmty_loc: location; + pmty_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and module_type_desc = Parsetree.module_type_desc = + | Pmty_ident of longident_loc + (* S *) + | Pmty_signature of signature + (* sig ... end *) + | Pmty_functor of string loc * module_type option * module_type + (* functor(X : MT1) -> MT2 *) + | Pmty_with of module_type * with_constraint list + (* MT with ... *) + | Pmty_typeof of module_expr + (* module type of ME *) + | Pmty_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + | Pmty_alias of longident_loc + (* (module M) *) + +and signature = signature_item list + +and signature_item = Parsetree.signature_item = + { + psig_desc: signature_item_desc; + psig_loc: location; + } + +and signature_item_desc = Parsetree.signature_item_desc = + | Psig_value of value_description + (* + val x: T + external x: T = "s1" ... "sn" + *) + | Psig_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Psig_typesubst of type_declaration list + (* type t1 := ... and ... and tn := ... *) + | Psig_typext of type_extension + (* type t1 += ... *) + | Psig_exception of type_exception + (* exception C of T *) + | Psig_module of module_declaration + (* module X : MT *) + | Psig_modsubst of module_substitution + (* module X := M *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + module type S *) + | Psig_open of open_description + (* open X *) + | Psig_include of include_description + (* include MT *) + | Psig_class of class_description list + (* class c1 : ... and ... and cn : ... *) + | Psig_class_type of class_type_declaration list + (* class type ct1 = ... and ... and ctn = ... *) + | Psig_attribute of attribute + (* [@@@id] *) + | Psig_extension of extension * attributes [@elpi.embed maybe_override_embed2 ] + (* [%%id] *) + +and module_declaration = Parsetree.module_declaration = + { + pmd_name: string loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: location; + } +(* S : MT *) + +and module_substitution = Parsetree.module_substitution = + { pms_name: string loc; + pms_manifest: longident_loc; + pms_attributes: attributes; + pms_loc: location; + } + +and module_type_declaration = Parsetree.module_type_declaration = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_loc: location; + } +(* S = MT + S (abstract module type declaration, pmtd_type = None) +*) + +and 'a open_infos = 'a Parsetree.open_infos = + { popen_expr: 'a; + popen_override: override_flag; + popen_loc: location; + popen_attributes: attributes; + } + +and open_description = longident_loc open_infos +(* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh +*) + +and open_declaration = module_expr open_infos + +and 'a include_infos = 'a Parsetree.include_infos = + { + pincl_mod: 'a; + pincl_loc: location; + pincl_attributes: attributes; + } + +and include_description = module_type include_infos +(* include MT *) + +and include_declaration = module_expr include_infos +(* include ME *) + +and with_constraint = Parsetree.with_constraint = + | Pwith_type of longident_loc * type_declaration + (* with type X.t = ... + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of longident_loc * longident_loc + (* with module X.Y = Z *) + | Pwith_typesubst of longident_loc * type_declaration + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_modsubst of longident_loc * longident_loc + (* with module X.Y := Z *) + +(* Value expressions for the module language *) + +and module_expr = Parsetree.module_expr = + { + pmod_desc: module_expr_desc; + pmod_loc: location; + pmod_attributes: attributes; (* ... [@id1] [@id2] *) + } + +and module_expr_desc = Parsetree.module_expr_desc = + | Pmod_ident of longident_loc + (* X *) + | Pmod_structure of structure + (* struct ... end *) + | Pmod_functor of string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr + (* ME1(ME2) *) + | Pmod_constraint of module_expr * module_type + (* (ME : MT) *) + | Pmod_unpack of expression + (* (val E) *) + | Pmod_extension of extension [@elpi.embed maybe_override_embed ] + (* [%id] *) + +and structure = structure_item list + +and structure_item = Parsetree.structure_item = + { + pstr_desc: structure_item_desc; + pstr_loc: location; + } + +and structure_item_desc = Parsetree.structure_item_desc = + | Pstr_eval of expression * attributes + (* E *) + | Pstr_value of rec_flag * value_binding list + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) + | Pstr_primitive of value_description + (* val x: T + external x: T = "s1" ... "sn" *) + | Pstr_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension + (* type t1 += ... *) + | Pstr_exception of type_exception + (* exception C of T + exception C = M.X *) + | Pstr_module of module_binding + (* module X = ME *) + | Pstr_recmodule of module_binding list + (* module rec X1 = ME1 and ... and Xn = MEn *) + | Pstr_modtype of module_type_declaration + (* module type S = MT *) + | Pstr_open of open_declaration + (* open X *) + | Pstr_class of class_declaration list + (* class c1 = ... and ... and cn = ... *) + | Pstr_class_type of class_type_declaration list + (* class type ct1 = ... and ... and ctn = ... *) + | Pstr_include of include_declaration + (* include ME *) + | Pstr_attribute of attribute + (* [@@@id] *) + | Pstr_extension of extension * attributes + (* [%%id] *) + +and value_binding = Parsetree.value_binding = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: location; + } + +and module_binding = Parsetree.module_binding = + { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: location; + } +(* X = ME *) + +(** {1 Toplevel} *) + +(* Toplevel phrases *) + +and toplevel_phrase = Parsetree.toplevel_phrase = + | Ptop_def of structure + | Ptop_dir of toplevel_directive + (* #use, #load ... *) + +and toplevel_directive = Parsetree.toplevel_directive = + { pdir_name : string loc; + pdir_arg : directive_argument option; + pdir_loc : location; + } +and directive_argument = Parsetree.directive_argument = + { pdira_desc : directive_argument_desc; + pdira_loc : location; + } + +and directive_argument_desc = Parsetree.directive_argument_desc = + | Pdir_string of string + | Pdir_int of string * char option + | Pdir_ident of longident + | Pdir_bool of bool +[@@deriving show, elpi { declaration = parsetree_declaration; mapper = parsetree_mapper }] + +let parsetree_declaration = !parsetree_declaration +let parsetree_mapper = !parsetree_mapper diff --git a/ocaml-elpi/tests/dune b/ocaml-elpi/tests/dune new file mode 100644 index 000000000..b653e1cc8 --- /dev/null +++ b/ocaml-elpi/tests/dune @@ -0,0 +1,27 @@ +(env + (dev + (flags (:standard -warn-error -A)))) + +(executable + (name pp) + (modules pp) + (libraries ocaml-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/ocaml-elpi/tests/dune.inc b/ocaml-elpi/tests/dune.inc new file mode 100644 index 000000000..624a88f47 --- /dev/null +++ b/ocaml-elpi/tests/dune.inc @@ -0,0 +1,15 @@ + +(rule + (targets test_swap.actual.ml) + (deps (:pp pp.exe) (:input test_swap.ml) ../ocaml_ast.elpi) + (action (run ./%{pp} --impl %{input} --cookie "program=\"test_swap.elpi\"" -o %{targets}))) + +(rule + (alias runtest) + (action (diff test_swap.expected.ml test_swap.actual.ml))) + +(executable + (name test_swap) + (modules test_swap) + (preprocess (pps ocaml-elpi.ppx -- --cookie "program=\"ocaml-elpi/tests/test_swap.elpi\""))) + diff --git a/ocaml-elpi/tests/gen_dune.ml b/ocaml-elpi/tests/gen_dune.ml new file mode 100644 index 000000000..31c8e10b5 --- /dev/null +++ b/ocaml-elpi/tests/gen_dune.ml @@ -0,0 +1,35 @@ + + +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) ../ocaml_ast.elpi) + (action (run ./%%{pp} --impl %%{input} --cookie "program=\"%s.elpi\"" -o %%{targets}))) + +(rule + (alias runtest) + (action (diff %s.expected.ml %s.actual.ml))) + +(executable + (name %s) + (modules %s) + (preprocess (pps ocaml-elpi.ppx -- --cookie "program=\"ocaml-elpi/tests/%s.elpi\""))) + +|} + 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/ocaml-elpi/tests/pp.ml b/ocaml-elpi/tests/pp.ml new file mode 100644 index 000000000..e3cba4049 --- /dev/null +++ b/ocaml-elpi/tests/pp.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/ocaml-elpi/tests/test_swap.elpi b/ocaml-elpi/tests/test_swap.elpi new file mode 100644 index 000000000..04201207a --- /dev/null +++ b/ocaml-elpi/tests/test_swap.elpi @@ -0,0 +1,3 @@ +map.value-binding (value-binding {{:pat ( [%e "P1"], [%e "P2" ] ) }} E X L) + (value-binding {{:pat ( [%e "P2"], [%e "P1" ] ) }} E X L) :- !. + diff --git a/ocaml-elpi/tests/test_swap.expected.ml b/ocaml-elpi/tests/test_swap.expected.ml new file mode 100644 index 000000000..0d195515d --- /dev/null +++ b/ocaml-elpi/tests/test_swap.expected.ml @@ -0,0 +1 @@ +let (y, x) = (3, 4) diff --git a/ocaml-elpi/tests/test_swap.ml b/ocaml-elpi/tests/test_swap.ml new file mode 100644 index 000000000..2bc0d5cb6 --- /dev/null +++ b/ocaml-elpi/tests/test_swap.ml @@ -0,0 +1 @@ +let x, y = 3, 4 \ No newline at end of file diff --git a/ocaml-elpi/vendored/README.md b/ocaml-elpi/vendored/README.md new file mode 100644 index 000000000..c1672dcd4 --- /dev/null +++ b/ocaml-elpi/vendored/README.md @@ -0,0 +1 @@ +We need ppx_show in ast_ocaml_elpi.ml, but version 0.2 is not in opam \ No newline at end of file diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/.gitignore b/ocaml-elpi/vendored/ppx_show-0.2.0/.gitignore new file mode 100644 index 000000000..1d9165198 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/.gitignore @@ -0,0 +1,5 @@ +*~ +/_build +*.install +*.opam +.merlin diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/ChangeLog b/ocaml-elpi/vendored/ppx_show-0.2.0/ChangeLog new file mode 100644 index 000000000..b3e91d596 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/ChangeLog @@ -0,0 +1,7 @@ +# 2019-09-09, version 0.2.0 + +- Reverse the parenthesis and the constructor name for single argument, + to make more outputs parsable by OCaml (e.g. `Constructor (ref (42))`) + (Suggested by Sebastien Mondet). + +- Update to ppxlib 0.9.0 (OCaml 4.08 syntax tree). diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/LICENSE b/ocaml-elpi/vendored/ppx_show-0.2.0/LICENSE new file mode 100644 index 000000000..6aa4e2d26 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2019, MARTINEZ Thierry +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/Makefile b/ocaml-elpi/vendored/ppx_show-0.2.0/Makefile new file mode 100644 index 000000000..104b21dd8 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/Makefile @@ -0,0 +1,38 @@ +DUNE := dune +DUNE_PREFIX := _build/default + +tests_dir = tests +tests := $(notdir $(wildcard $(tests_dir)/*)) + +# All targets are phony targets since we want to rely on dune for +# dependency management. + +.PHONY : all + +all : + dune build + +ppx_show.opam : dune-project + dune build ppx_show.opam + +.PHONY : clean + +clean : + dune clean + +.PHONY : install + +install : + dune build @install + dune install + +.PHONY : tests +tests : $(tests) + +define foreach_test +.PHONY : $(test) +$(test) : + $(DUNE) build $(tests_dir)/$(test)/$(test).exe + $(DUNE_PREFIX)/$(tests_dir)/$(test)/$(test).exe +endef +$(foreach test,$(tests),$(eval $(foreach_test))) diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/README.md b/ocaml-elpi/vendored/ppx_show-0.2.0/README.md new file mode 100644 index 000000000..30da8d795 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/README.md @@ -0,0 +1,7 @@ +# OCaml PPX deriver for deriving `show` based on `ppxlib`. + +This library reimplements the `show` plugin from [`ppx_deriving`] as a +`ppxlib` deriver. +In particular, this deriver works with OCaml 4.08.0. + +[`ppx_deriving`]: https://github.com/ocaml-ppx/ppx_deriving \ No newline at end of file diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/dune-project b/ocaml-elpi/vendored/ppx_show-0.2.0/dune-project new file mode 100644 index 000000000..78aee28f0 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/dune-project @@ -0,0 +1,20 @@ +(lang dune 1.10) + +(generate_opam_files true) + +(license BSD) +(maintainers "Thierry Martinez ") +(authors "Thierry Martinez ") +(source (uri "git+https://gitlab.inria.fr/tmartine/ppx_show")) +(homepage "https://gitlab.inria.fr/tmartine/ppx_show") +(bug_reports "https://gitlab.inria.fr/tmartine/ppx_show") +(documentation "https://gitlab.inria.fr/tmartine/ppx_show") +(version "0.2.0") + +(package + (name ppx_show) + (synopsis "OCaml PPX deriver for deriving show based on ppxlib") + (depends + (ppxlib (>= 0.9.0)) + (stdcompat (>= 9)))) + diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/dune b/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/dune new file mode 100644 index 000000000..d782856fa --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/dune @@ -0,0 +1,3 @@ +(library + (name ppx_show_runtime) + (public_name ppx_show.runtime)) \ No newline at end of file diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.ml b/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.ml new file mode 100644 index 000000000..ff74a6658 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.ml @@ -0,0 +1,29 @@ +module Format = Format + +module String = String + +module Int32 = Int32 + +module Int64 = Int64 + +module Nativeint = Nativeint + +module Bytes = Bytes + +module Lazy = Lazy + +let pp_list pp_item fmt items = + Format.pp_open_box fmt 1; + Format.pp_print_string fmt "["; + begin match items with + | [] -> () + | hd :: tl -> + pp_item fmt hd; + tl |> List.iter begin fun item -> + Format.pp_print_string fmt ";"; + Format.pp_print_space fmt (); + pp_item fmt item + end + end; + Format.pp_print_string fmt "]"; + Format.pp_close_box fmt () diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.mli b/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.mli new file mode 100644 index 000000000..5664f8ccd --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/runtime/ppx_show_runtime.mli @@ -0,0 +1,17 @@ +module Format = Format + +module String = String + +module Int32 = Int32 + +module Int64 = Int64 + +module Nativeint = Nativeint + +module Bytes = Bytes + +module Lazy = Lazy + +val pp_list : + (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/src/dune b/ocaml-elpi/vendored/ppx_show-0.2.0/src/dune new file mode 100644 index 000000000..006779b07 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/src/dune @@ -0,0 +1,7 @@ +(library + (public_name ppx_show) + (kind ppx_rewriter) + (preprocess (pps ppxlib.metaquot)) +; -warning 40: Constructor or label name used out of scope. (OCaml <=4.06.0) + (flags -open Stdcompat -w -40) + (libraries ppxlib stdcompat)) \ No newline at end of file diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/src/ppx_show.ml b/ocaml-elpi/vendored/ppx_show-0.2.0/src/ppx_show.ml new file mode 100644 index 000000000..d8efaf57c --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/src/ppx_show.ml @@ -0,0 +1,413 @@ +open Ppxlib + +let attr_nobuiltin : (core_type, unit -> unit) Ppxlib.Attribute.t = + Ppxlib.Attribute.declare "deriving.show.nobuiltin" Core_type + (Ppxlib.Ast_pattern.(pstr nil)) + Fun.id + +let attr_opaque : (core_type, unit -> unit) Ppxlib.Attribute.t = + Ppxlib.Attribute.declare "deriving.show.opaque" Core_type + (Ppxlib.Ast_pattern.(pstr nil)) + Fun.id + +let attr_printer : (core_type, expression) Ppxlib.Attribute.t = + Ppxlib.Attribute.declare "deriving.show.printer" Core_type + (Ppxlib.Ast_pattern.(single_expr_payload __)) + Fun.id + +let attr_polyprinter : (core_type, expression) Ppxlib.Attribute.t = + Ppxlib.Attribute.declare "deriving.show.polyprinter" Core_type + (Ppxlib.Ast_pattern.(single_expr_payload __)) + Fun.id + +let pp_open_box i : expression = + let loc = !Ast_helper.default_loc in + [%expr Ppx_show_runtime.Format.pp_open_box fmt + [%e (Ast_helper.Exp.constant (Ast_helper.Const.int i))]] + +let pp_close_box () : expression = + let loc = !Ast_helper.default_loc in + [%expr Ppx_show_runtime.Format.pp_close_box fmt ()] + +let pp_print_space () : expression = + let loc = !Ast_helper.default_loc in + [%expr Ppx_show_runtime.Format.pp_print_space fmt ()] + +let pp_print_string_expression e : expression = + let loc = !Ast_helper.default_loc in + [%expr Ppx_show_runtime.Format.pp_print_string fmt + [%e e]] + +let pp_print_string s = + pp_print_string_expression + (Ast_helper.Exp.constant (Ast_helper.Const.string s)) + +let pp_list_of_record ~path (fields : (string * expression list) list) + : expression list = + List.flatten [ + [pp_open_box 2; pp_print_string "{ "]; + List.flatten begin + Tools.separate [pp_print_string ";"; pp_print_space ()] + begin fields |> List.map begin fun (name, value) -> + let name = Tools.expand_path ~path name in + pp_open_box 0 :: pp_print_string (name ^ " =") :: pp_print_space () + :: value @ [pp_close_box ()] + end end + end; + [pp_print_space (); pp_print_string "}"; pp_close_box ()]] + +let pp_list_of_tuple (values : expression list list) : expression list = + List.flatten [ + [pp_open_box 1; pp_print_string "("]; + List.flatten begin + Tools.separate [pp_print_string ","; pp_print_space ()] + begin values |> List.map begin fun value -> + pp_open_box 0 :: value @ [pp_close_box ()] + end end + end; + [pp_print_string ")"; pp_close_box ()]] + +let binders_of_printers printers = + printers |> List.mapi begin fun i printer -> + let binder = "x" ^ string_of_int i in + Tools.pat_var_of_string binder, printer (Tools.ident_of_string binder) + end |> List.split + +type constructor_arguments = + | No_argument + | Singleton of (expression -> expression list) + | Tuple of (expression -> expression list) list + +type kind = + | Construct + | Variant + +let pp_cases_of_cases ?(path = []) kind cases = + cases |> List.map begin fun (constr, arguments) -> + let pat, constr = + match kind with + | Construct -> + let loc = !Ast_helper.default_loc in + Ast_helper.Pat.construct { loc; txt = Lident constr }, + Tools.expand_path ~path constr + | Variant -> + Ast_helper.Pat.variant constr, "`" ^ constr in + let arguments, printers = + match arguments with + | No_argument -> None, [pp_print_string constr] + | Singleton printer -> + let binder = "x" in + Some (Tools.pat_var_of_string binder), + begin + pp_open_box 1 :: + pp_print_string (constr ^ " (") :: + printer (Tools.ident_of_string binder) @ + [pp_print_string ")"; pp_close_box ()] + end + | Tuple printers -> + let binders, printers = binders_of_printers printers in + Some (Ast_helper.Pat.tuple binders), + begin + pp_open_box 0 :: + pp_print_string constr :: + pp_print_space () :: + pp_list_of_tuple printers @ + [pp_close_box ()] + end in + Ast_helper.Exp.case (pat arguments) (Tools.seq printers) + end + +let rec pp_list_of_type (ty : core_type) (value : expression) + : expression list = + let loc = ty.ptyp_loc in + match Ppxlib.Attribute.get attr_printer ty with + | Some printer -> + [Ast_helper.Exp.apply printer [Nolabel, [%expr fmt]; Nolabel, value]] + | None -> + if Ppxlib.Attribute.get attr_opaque ty = None then + match ty with + | { ptyp_desc = Ptyp_any; _ } -> + [pp_print_string "_"] + | { ptyp_desc = Ptyp_arrow _; _ } -> + [pp_print_string ""] + | { ptyp_desc = Ptyp_tuple types; _ } -> + let binders, printers = + binders_of_printers (types |> List.map pp_list_of_type) in + [Ast_helper.Exp.let_ Nonrecursive [Ast_helper.Vb.mk (Ast_helper.Pat.tuple binders) value] + (Tools.seq (pp_list_of_tuple printers))] + | { ptyp_desc = Ptyp_variant (fields, _, _); _ } -> + let cases = + fields |> List.map begin fun (field : row_field) -> + match field.prf_desc with + | Rtag (label, true, _) -> + label.txt, No_argument + | Rtag (label, false, ty :: _) -> + label.txt, Singleton (pp_list_of_type ty) + | _ -> + failwith "Not implemented open tag" + end in + [Ast_helper.Exp.match_ value (pp_cases_of_cases Variant cases)] + | { ptyp_desc = Ptyp_var x; _ } -> + [Ast_helper.Exp.apply + (Ast_helper.Exp.ident { loc; txt = Lident (Tools.poly_var x)}) + [Nolabel, [%expr fmt]; Nolabel, value]] + | { ptyp_desc = Ptyp_constr (constr, arguments); _ } -> + begin match + if Ppxlib.Attribute.get attr_nobuiltin ty = None then + pp_list_of_builtin_type ty value + else + [] + with + | [] -> + let printer = + match Ppxlib.Attribute.get attr_polyprinter ty with + | None -> + Ast_helper.Exp.ident (constr |> + Tools.map_loc (Tools.mangle_lid (Prefix "pp"))) + | Some printer -> printer in + [Ast_helper.Exp.apply printer + begin + begin arguments |> List.map begin + fun ty : (arg_label * expression) -> + Nolabel, [%expr fun fmt x -> + [%e Tools.seq (pp_list_of_type ty [%expr x])]] + end end @ + [Nolabel, [%expr fmt]; Nolabel, value] + end] + | list -> list + end + | _ -> + Location.raise_errorf "ppx_show: Not implemented %a" + (Pprintast.core_type) ty + else + [pp_print_string ""] + +and pp_list_of_builtin_type (ty : core_type) (value : expression) + : expression list = + let loc = ty.ptyp_loc in + match ty with + | [%type: unit] -> [pp_print_string "()"] + | [%type: int] -> + [[%expr Ppx_show_runtime.Format.pp_print_int fmt [%e value]]] + | [%type: int32] -> + [pp_print_string_expression + [%expr Ppx_show_runtime.Int32.to_string [%e value]]; + pp_print_string "l"] + | [%type: int64] -> + [pp_print_string_expression + [%expr Ppx_show_runtime.Int64.to_string [%e value]]; + pp_print_string "L"] + | [%type: nativeint] -> + [pp_print_string_expression + [%expr Ppx_show_runtime.Nativeint.to_string [%e value]]; + pp_print_string "n"] + | [%type: float] -> + [[%expr Ppx_show_runtime.Format.pp_print_float fmt [%e value]]] + | [%type: bool] -> + [[%expr Ppx_show_runtime.Format.pp_print_bool fmt [%e value]]] + | [%type: char] -> + [[%expr Ppx_show_runtime.Format.pp_print_char fmt [%e value]]] + | [%type: string] -> + [pp_print_string "\""; + pp_print_string_expression + [%expr Ppx_show_runtime.String.escaped [%e value]]; + pp_print_string "\""] + | [%type: bytes] -> + [pp_print_string "\""; + pp_print_string_expression + [%expr Ppx_show_runtime.String.escaped + (Ppx_show_runtime.Bytes.to_string [%e value])]; + pp_print_string "\""] + | [%type: [%t? ty] ref] -> + pp_open_box 1 :: pp_print_string "ref (" :: + pp_list_of_type ty [%expr ! [%e value]] @ + [pp_print_string ")"; pp_close_box ()] + | [%type: [%t? ty] Lazy.t] -> + [pp_open_box 1; pp_print_string "lazy ("; + [%expr + if Ppx_show_runtime.Lazy.is_val [%e value] then + [%e Tools.seq (pp_list_of_type ty + [%expr Ppx_show_runtime.Lazy.force [%e value]])] + else + Ppx_show_runtime.Format.pp_print_string fmt ""]; + pp_print_string ")"; pp_close_box ()] + | [%type: [%t? sub] option] -> + [Ast_helper.Exp.match_ + (Ast_helper.Exp.constraint_ value [%type: _ option]) begin + pp_cases_of_cases Construct [ + "None", No_argument; + "Some", Singleton (fun x -> pp_list_of_type sub x)] + end] + | [%type: ([%t? ok], [%t? error]) result] -> + [Ast_helper.Exp.match_ + (Ast_helper.Exp.constraint_ value [%type: (_, _) result]) begin + pp_cases_of_cases Construct [ + "Ok", Singleton (fun x -> pp_list_of_type ok x); + "Error", Singleton (fun x -> pp_list_of_type error x)] + end] + | [%type: [%t? ty] list] -> + [[%expr Ppx_show_runtime.pp_list (fun fmt x -> + [%e Tools.seq (pp_list_of_type ty [%expr x])]) fmt [%e value]]] + | _ -> [] + +let pp_list_of_label_declaration_list ?(path = []) + (labels : label_declaration list) + (value : expression) : expression list = + let fields = labels |> List.map begin fun (label : label_declaration) -> + label.pld_name.txt, + pp_list_of_type label.pld_type (Ast_helper.Exp.field value + (label.pld_name |> Tools.map_loc (fun name : Longident.t -> + Lident name))) + end in + pp_list_of_record ~path fields + +let pp_of_variant ~with_path (constrs : constructor_declaration list) + (value : expression) : expression = + let cases = + constrs |> List.map begin fun (constr : constructor_declaration) -> + constr.pcd_name.txt, + match constr.pcd_args with + | Pcstr_tuple [] -> No_argument + | Pcstr_tuple [ty] -> Singleton (pp_list_of_type ty) + | Pcstr_tuple list -> + Tuple (list |> List.map pp_list_of_type) + | Pcstr_record labels -> + Singleton (pp_list_of_label_declaration_list labels) + end in + let path = + match with_path with + | None -> [] + | Some path -> path in + Ast_helper.Exp.match_ value (pp_cases_of_cases ~path Construct cases) + +let pp_of_record ~with_path (labels : label_declaration list) + (value : expression) : expression = + let path = + match with_path with + | None -> [] + | Some path -> path in + Tools.seq (pp_list_of_label_declaration_list ~path labels value) + +let pp = "pp" + +let show = "show" + +let fmt_ty (ty : core_type) : core_type = + let loc = ty.ptyp_loc in + [%type: Ppx_show_runtime.Format.formatter -> [%t ty] -> unit] + +let type_of_type_decl (td : type_declaration) : core_type = + let loc = td.ptype_loc in + Ast_helper.with_default_loc loc begin fun () -> + let ty = Tools.core_type_of_type_decl td in + Tools.poly_arrow_of_type_decl fmt_ty td (fmt_ty ty) + end + +let pp_of_type_decl ~with_path (td : type_declaration) : value_binding = + let with_path = + match with_path with + | None -> None + | Some path -> Some (Tools.path_of_type_decl ~path td) in + let loc = td.ptype_loc in + Ast_helper.with_default_loc loc begin fun () -> + let name = Tools.mangle_type_decl (Prefix pp) td in + let printer : expression = + match td.ptype_kind with + | Ptype_abstract -> + begin match td.ptype_manifest with + | None -> + Location.raise_errorf ~loc + "show cannot be derived for fully abstract types" + | Some ty -> + Tools.seq (pp_list_of_type ty [%expr x]) + end + | Ptype_variant constrs -> + pp_of_variant ~with_path constrs [%expr x] + | Ptype_record labels -> + pp_of_record ~with_path labels [%expr x] + | Ptype_open -> + Location.raise_errorf ~loc "show cannot be derived for open types" in + let printer : expression = + [%expr fun fmt x -> + [%e printer]] in + let printer = Tools.poly_fun_of_type_decl td printer in + let constraint_ = + Ast_helper.Typ.poly (td.ptype_params |> List.map begin + fun (ty, _) : string Location.loc -> + { loc = ty.ptyp_loc; txt = Tools.var_of_type ty } + end) + (type_of_type_decl td) in + Ast_helper.Vb.mk + ~attrs:[Ast_helper.Attr.mk + { loc; txt = "ocaml.warning" } (PStr [%str "-39"])] + (Ast_helper.Pat.constraint_ (Ast_helper.Pat.var name) constraint_) printer + end + +let show_of_type_decl (td : type_declaration) : value_binding = + let loc = td.ptype_loc in + Ast_helper.with_default_loc loc begin fun () -> + let name = Tools.mangle_type_decl (Prefix show) td in + let printer_name = Tools.mangle_type_decl (Prefix pp) td in + let printer : expression = + Tools.poly_apply_of_type_decl td (Tools.ident_of_str printer_name) in + let printer : expression = + [%expr fun x -> + Ppx_show_runtime.Format.asprintf "@[%a@]" [%e printer] x] in + let printer = Tools.poly_fun_of_type_decl td printer in + Ast_helper.Vb.mk (Ast_helper.Pat.var name) printer + end + +let pp_type_of_type_decl (td : type_declaration) : value_description = + let loc = td.ptype_loc in + Ast_helper.with_default_loc loc begin fun () -> + let name = Tools.mangle_type_decl (Prefix pp) td in + Ast_helper.Val.mk name (type_of_type_decl td) + end + +let show_type_of_type_decl (td : type_declaration) : value_description = + let loc = td.ptype_loc in + Ast_helper.with_default_loc loc begin fun () -> + let name = Tools.mangle_type_decl (Prefix show) td in + let ty = Tools.core_type_of_type_decl td in + let ty = + Tools.poly_arrow_of_type_decl fmt_ty td + (Ast_helper.Typ.arrow Nolabel ty [%type: string]) in + Ast_helper.Val.mk name ty + end + +let make_str ~loc ~path (rec_flag, tds) (with_path : expression option) + : structure = + let with_path = + match with_path with + | Some [%expr false] -> None + | _ -> + match String.split_on_char '.' (Filename.basename path) with + | filename :: "ml" :: path + | filename :: _ :: "ml" :: path -> + Some (String.capitalize_ascii filename :: path) + | _ -> prerr_endline path; assert false in + let vbs = tds |> List.map (pp_of_type_decl ~with_path) in + [Ast_helper.Str.value ~loc rec_flag vbs; + Ast_helper.Str.value ~loc Nonrecursive (tds |> List.map show_of_type_decl)] + +let str_type_decl = + Ppxlib.Deriving.Generator.make + Ppxlib.Deriving.Args.(empty +> + arg "with_path" __) + make_str + +let make_sig ~loc ~path:_ (_rec_flag, tds) : signature = + let vds = tds |> List.map pp_type_of_type_decl in + let shows = tds |> List.map show_type_of_type_decl in + (vds |> List.map (fun vd -> Ast_helper.Sig.value ~loc vd)) @ + (shows |> List.map (fun vd -> Ast_helper.Sig.value ~loc vd)) + +let sig_type_decl = Ppxlib.Deriving.Generator.make_noarg make_sig + +let extension ~loc ~path:_ ty : expression = + let binder = "x" in + [%expr fun fmt x -> + [%e Tools.seq (pp_list_of_type ty (Tools.ident_of_string binder))]] + +let deriver = + Ppxlib.Deriving.add "show" ~str_type_decl ~sig_type_decl ~extension diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.ml b/ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.ml new file mode 100644 index 000000000..cef10bc86 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.ml @@ -0,0 +1,117 @@ +open Ppxlib + +let rec rev_map_append f list accu = + match list with + | [] -> accu + | hd :: tl -> rev_map_append f tl (List.rev_append (f hd) accu) + +let flatten_map f list = + List.rev (rev_map_append f list []) + +let map_loc (f : 'a -> 'b) ({ loc; txt } : 'a loc) : 'b loc = + { loc; txt = f txt } + +type affix = + | Prefix of string + | Suffix of string + | PrefixSuffix of string * string + +let mangle ?(fixpoint = "t") affix name = + if name = fixpoint then + match affix with + | Prefix x | Suffix x -> x + | PrefixSuffix (x, y) -> x ^ "_" ^ y + else + match affix with + | Prefix x -> x ^ "_" ^ name + | Suffix x -> name ^ "_" ^ x + | PrefixSuffix (x, y) -> x ^ "_" ^ name ^ "_" ^ y + +let mangle_type_decl ?fixpoint affix (td : type_declaration) : string loc = + map_loc (mangle ?fixpoint affix) td.ptype_name + +let mangle_lid ?fixpoint affix (lid : Longident.t) : Longident.t = + match lid with + | Lident s -> Lident (mangle ?fixpoint affix s) + | Ldot (p, s) -> Ldot (p, mangle ?fixpoint affix s) + | Lapply _ -> invalid_arg "mangle_lid" + +let seq ?(loc = !Ast_helper.default_loc) list : expression = + match List.rev list with + | [] -> [%expr ()] + | hd :: tl -> + List.fold_left begin fun acc item : expression -> + [%expr [%e item]; [%e acc]] + end hd tl + +let separate separator l = + match l with + | [] | [_] -> l + | hd :: tl -> + let revl = + List.fold_left begin fun acc x -> + x :: separator :: acc + end [] tl in + hd :: List.rev revl + +let poly_var x = + "poly_" ^ x + +let var_of_type (ty : core_type) = + match ty.ptyp_desc with + | Ptyp_var x -> x + | _ -> invalid_arg "var_of_type" + +let poly_fun_of_type_decl (td : type_declaration) (e : expression) + : expression = + let loc = !Ast_helper.default_loc in + List.fold_left begin fun acc (ty, _) : expression -> + let var = var_of_type ty in + [%expr fun [%p Ast_helper.Pat.var { loc; txt = poly_var var }] -> [%e acc]] + end e (List.rev td.ptype_params) + +let poly_arrow_of_type_decl (mkvar : core_type -> core_type) + (td : type_declaration) (ty : core_type) + : core_type = + let loc = !Ast_helper.default_loc in + List.fold_left begin fun acc ((ty : core_type), _) : core_type -> + [%type: [%t mkvar ty] -> [%t acc]] + end ty (List.rev td.ptype_params) + +let core_type_of_type_decl (td : type_declaration) : core_type = + Ast_helper.Typ.constr + (td.ptype_name |> map_loc (fun x : Longident.t -> Lident x)) + (List.map fst td.ptype_params) + +let expand_path ~path ident = + String.concat "." (path @ [ident]) + +let path_of_type_decl ~path (td : type_declaration) = + match td.ptype_manifest with + | Some { ptyp_desc = Ptyp_constr ({ txt = lid; _ }, _); _ } -> + begin match lid with + | Lident _ -> [] + | Ldot (lid, _) -> Ocaml_common.Longident.flatten lid + | Lapply _ -> assert false + end + | _ -> path + +let pat_var_of_string s = + let loc = !Ast_helper.default_loc in + Ast_helper.Pat.var { loc; txt = s } + +let ident_of_string s = + let loc = !Ast_helper.default_loc in + Ast_helper.Exp.ident { loc; txt = Lident s } + +let ident_of_str ({ loc; txt } : string Location.loc) = + Ast_helper.Exp.ident { loc; txt = Lident txt } + +let poly_apply_of_type_decl (td : type_declaration) (e : expression) = + match td.ptype_params with + | [] -> e + | _ -> + Ast_helper.Exp.apply e begin td.ptype_params |> List.map begin + fun (ty, _) : (arg_label * expression) -> + Nolabel, ident_of_string (poly_var (var_of_type ty)) + end end diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.mli b/ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.mli new file mode 100644 index 000000000..9b7782cc6 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/src/tools.mli @@ -0,0 +1,46 @@ +open Ppxlib + +val flatten_map : ('a -> 'b list) -> 'a list -> 'b list +(** [flatten_map f list] is equal to [List.flatten (List.map f list)]. *) + +val map_loc : ('a -> 'b) -> 'a Location.loc -> 'b Location.loc + +type affix = + | Prefix of string + | Suffix of string + | PrefixSuffix of string * string + +val mangle : ?fixpoint : string -> affix -> string -> string + +val mangle_lid : ?fixpoint : string -> affix -> Longident.t -> Longident.t + +val mangle_type_decl : + ?fixpoint : string -> affix -> type_declaration -> string Location.loc + +val seq : ?loc : Location.t -> expression list -> expression + +val separate : 'a -> 'a list -> 'a list + +val poly_var : string -> string + +val poly_fun_of_type_decl : type_declaration -> expression -> expression + +val poly_arrow_of_type_decl : + (core_type -> core_type) -> type_declaration -> core_type + -> core_type + +val core_type_of_type_decl : type_declaration -> core_type + +val expand_path : path : string list -> string -> string + +val path_of_type_decl : path : string list -> type_declaration -> string list + +val pat_var_of_string : string -> pattern + +val ident_of_string : string -> expression + +val ident_of_str : string Location.loc -> expression + +val poly_apply_of_type_decl : type_declaration -> expression -> expression + +val var_of_type : core_type -> string diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/dune b/ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/dune new file mode 100644 index 000000000..fb5419938 --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/dune @@ -0,0 +1,5 @@ +(executable + (name show) + (preprocess (pps ppx_show)) + ; (flags -dsource) + (libraries ppx_show_runtime)) \ No newline at end of file diff --git a/ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/show.ml b/ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/show.ml new file mode 100644 index 000000000..143af3d1d --- /dev/null +++ b/ocaml-elpi/vendored/ppx_show-0.2.0/tests/show/show.ml @@ -0,0 +1,111 @@ +type enum = A | B of int | C of bool * int | D of { a : int; b : string } + [@@deriving show] + +let exit_code = ref 0 + +let string_match line s s' = + if s <> s' then + begin + Format.eprintf "Mismatch at line %d: got \"%s\" but \"%s\" expected@." + line (String.escaped s) (String.escaped s'); + exit_code := 1 + end + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int32] 1l) "1l" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int64] 1L) "1L" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: nativeint] 1n) "1n" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: float] 1.) "1." + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int option] (Some 1)) "Some (1)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int ref] (ref 1)) "ref (1)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int Lazy.t] (lazy 1)) "lazy (1)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: (int, unit) result] (Error ())) + "Error (())" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int list] [1; 2; 3]) "[1; 2; 3]" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int * bool * string] (1, false, "a")) + "(1, false, \"a\")" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: [`A | `B of int]] `A) "`A" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: [`A | `B of int]] (`B 1)) "`B (1)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: [`A | `B of int * int]] (`B (1, 2))) + "`B ((1, 2))" + +let () = + string_match __LINE__ (Format.asprintf "@[%a@]" pp_enum A) "Show.A" + +let () = + string_match __LINE__ (Format.asprintf "@[%a@]" pp_enum (B 1)) "Show.B (1)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" pp_enum (C (false, 2))) "Show.C (false, 2)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" pp_enum (D { a = 1; b = "foo" })) + "Show.D ({ a = 1; b = \"foo\" })" + +type 'a poly = A of enum | B of 'a poly * 'a + [@@deriving show { with_path = false }] + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" (pp_poly pp_enum) (A A)) "A (Show.A)" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" (pp_poly pp_enum) (B (A A, A))) + "B (A (Show.A), Show.A)" + +let pp_int fmt _ = Format.pp_print_string fmt "a" + +let () = + string_match __LINE__ + (Format.asprintf "@[%a@]" [%show: int [@show.nobuiltin]] 1) "a" + +module Test : sig + type t = A [@@deriving show] +end = struct + type t = A [@@deriving show] +end + +let () = + string_match __LINE__ (Test.show A) "Show.Test.A" + +let () = exit !exit_code