wip

Author: gares

ocaml-elpi/main_ocaml_elpi_rewriter.ml

@@ -57,7 +57,7 @@ ocaml-elpi.ppx: no program specified. Supported options:
   let query =
     let open Query in
     compile program (Ast.Loc.initial "ppx") @@
-      Query { predicate = "map.structure"; arguments = D(structure,s,(Q(structure,"Result",N))) } in
+      CQuery ("map.structure", DC(structure,s,(QC(structure,"Result",NC))),new ctx_for_structure [],RawData.no_constraints) in
   if !typecheck then begin
     if not @@ Compile.static_check ~checker:Elpi.Builtin.(default_checker ()) query then begin
       exit 1
@@ -77,13 +77,16 @@ let erase_loc =
   object
     inherit [State.t] Ast_traverse.fold_map
     method! location _ (st : State.t) = Ocaml_ast_for_elpi.dummy_location, st
+    method! location_stack l (st : State.t) = [], 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 = (expression).Conversion.embed ~depth state e in
+  let ctx = new ctx_for_expression [] state in
+  let csts = RawData.no_constraints in
+  let state, x, gls = (expression).ContextualConversion.embed ~depth ctx csts state e in
   assert(gls = []);
   state, x
 
@@ -93,7 +96,9 @@ 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 = (pattern).Conversion.embed ~depth state e in
+  let ctx = new ctx_for_pattern [] state in
+  let csts = RawData.no_constraints in
+  let state, x, gls = (pattern).ContextualConversion.embed ~depth ctx csts state e in
   assert(gls = []);
   state, x
 
@@ -102,7 +107,9 @@ 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 = (core_type).Conversion.embed ~depth state e in
+  let ctx = new ctx_for_core_type [] state in
+  let csts = RawData.no_constraints in
+  let state, x, gls = (core_type).ContextualConversion.embed ~depth ctx csts state e in
   assert(gls = []);
   state, x
 
@@ -113,7 +120,9 @@ let stri_quotation ~depth state _loc s =
   match e with
   | Ptop_def [e] ->
       let e, state = erase_loc#structure_item e state in
-      let state, x, gls = (structure_item).Conversion.embed ~depth state e in
+      let ctx = new ctx_for_structure_item [] state in
+      let csts = RawData.no_constraints in
+      let state, x, gls = (structure_item).ContextualConversion.embed ~depth ctx csts state e in
       assert(gls = []);
       state, x
   | Ptop_def _ ->
@@ -128,7 +137,9 @@ let sigi_quotation ~depth state _loc s =
   match e with
   | [e] ->
       let e, state = erase_loc#signature_item e state in
-      let state, x, gls = (signature_item).Conversion.embed ~depth state e in
+      let ctx = new ctx_for_signature_item [] state in
+      let csts = RawData.no_constraints in
+      let state, x, gls = (signature_item).ContextualConversion.embed ~depth ctx csts state e in
       assert(gls = []);
       state, x
   | _ ->
@@ -139,7 +150,9 @@ 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 = (structure).Conversion.embed ~depth state e in
+  let ctx = new ctx_for_structure [] state in
+  let csts = RawData.no_constraints in
+  let state, x, gls = (structure).ContextualConversion.embed ~depth ctx csts state e in
   assert(gls = []);
   state, x
 
@@ -148,7 +161,9 @@ 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 = (signature).Conversion.embed ~depth state e in
+  let ctx = new ctx_for_signature [] state in
+  let csts = RawData.no_constraints in
+  let state, x, gls = (signature).ContextualConversion.embed ~depth ctx csts state e in
   assert(gls = []);
   state, x
 
@@ -166,7 +181,7 @@ 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

ocaml-elpi/ocaml_ast_for_elpi.ml

@@ -31,23 +31,23 @@ let dummy_location =
     loc_ghost = false
   }
 
-let maybe_override_embed default = fun ~depth st e ->
+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 st e
+  | e -> default ~depth h c st e
 
-let maybe_override_embed2 default = fun ~depth st e a ->
+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 st e a
+  | _ -> default ~depth h c st e a
 
 module Warnings = struct
   include Warnings
@@ -109,16 +109,16 @@ and location = Location.t = {
   loc_start: position;
   loc_end: position;
   loc_ghost: bool;
-} [@@elpi.embed fun default ~depth st start end_ ghost ->
+} [@@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 st start end_ ghost ]
-  [@@elpi.default_constructor_readback fun default ~depth st t ->
+         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 st t]
+       | _ -> default ~depth h c st t]
 
 and location_stack = location list
 
@@ -1111,7 +1111,5 @@ and directive_argument_desc = Parsetree.directive_argument_desc =
   | Pdir_bool of bool
 [@@deriving show, elpi { declaration = parsetree_declaration; mapper = parsetree_mapper }]
 
-
-
 let parsetree_declaration = !parsetree_declaration
 let parsetree_mapper = !parsetree_mapper

ocaml-elpi/tests/dune.inc

@@ -1,7 +1,7 @@
 
 (rule
  (targets test_swap.actual.ml)
- (deps (:pp pp.exe) (:input test_swap.ml) ../ocaml_ast.elpi)
+ (deps (:pp pp.exe) (:input test_swap.ml) ../ocaml_ast.elpi test_swap.elpi)
  (action (run ./%{pp} --impl %{input} --cookie "program=\"test_swap.elpi\"" -o %{targets})))
 
 (rule

ocaml-elpi/tests/gen_dune.ml

@@ -5,7 +5,7 @@ let output_stanzas filename =
   Printf.printf {|
 (rule
  (targets %s.actual.ml)
- (deps (:pp pp.exe) (:input %s.ml) ../ocaml_ast.elpi)
+ (deps (:pp pp.exe) (:input %s.ml) ../ocaml_ast.elpi %s.elpi)
  (action (run ./%%{pp} --impl %%{input} --cookie "program=\"%s.elpi\"" -o %%{targets})))
 
 (rule
@@ -18,7 +18,7 @@ let output_stanzas filename =
   (preprocess (pps ocaml-elpi.ppx -- --cookie "program=\"ocaml-elpi/tests/%s.elpi\"")))
 
 |}
-  base base base base base base base base
+  base base base base base base base base base
 
 let is_test filename =
   Filename.check_suffix filename ".ml" &&

ocaml-elpi/tests/test_swap.elpi

@@ -1,3 +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) :- !.
-