ppx

.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
 

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

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 \

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)

ppx_elpi/tests/dune

@@ -5,6 +5,7 @@
 (executable
  (name pp)
  (modules pp)
+ (promote)
  (libraries elpi.ppx ppxlib))
 
 (include dune.inc)

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))

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).
-
 
 
 

ppx_elpi/tests/test_alias_type.expected.ml

@@ -1,37 +1,30 @@
 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"]
     let elpi_constant_type_simple = "simple"
     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 =

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 ()
+main ()

ppx_elpi/tests/test_double_contextual.expected.elpi

@@ -1,37 +1,23 @@
 
 
-% tctx
-kind tctx type.
+% tyctx
+kind tyctx 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.
+% tctx
+kind tctx 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).
-
-
-