Wildcards 2025

ppx/distrib/ppx_distrib_expander.ml

@@ -787,36 +787,36 @@ let process_main ~loc rec_ (base_tdecl, tdecl) =
 ;;
 *)
 (* let prepare_reifiers (rs : Reifier_info.t list) =
-     let names = [] (* type params of original decl *) in
-     let mk_arg_reifier s = sprintf "r%s" s in
-     let add_args tdecl rhs =
-       let loc = tdecl.ptype_loc in
-       Exp.funs ~loc rhs (List.map ~f:mk_arg_reifier names)
-     in
-     match rs with
-     | [] -> []
-     | [ h ] ->
-         let loc = h.Reifier_info.decl.ptype_loc in
-         let pat = ppat_var ~loc (Located.mk ~loc h.Reifier_info.name) in
-         [ value_binding ~loc ~pat ~expr:(add_args h.Reifier_info.decl h.Reifier_info.body) ]
-     | rs ->
-         let mutual_names = List.map rs ~f:(fun { Reifier_info.decl } -> decl.ptype_name.txt) in
-         let mutual_args ~loc e =
-           pexp_fun
-             ~loc
-             nolabel
-             None
-             (ppat_tuple
+        let names = [] (* type params of original decl *) in
+        let mk_arg_reifier s = sprintf "r%s" s in
+        let add_args tdecl rhs =
+          let loc = tdecl.ptype_loc in
+          Exp.funs ~loc rhs (List.map ~f:mk_arg_reifier names)
+        in
+        match rs with
+        | [] -> []
+        | [ h ] ->
+            let loc = h.Reifier_info.decl.ptype_loc in
+            let pat = ppat_var ~loc (Located.mk ~loc h.Reifier_info.name) in
+            [ value_binding ~loc ~pat ~expr:(add_args h.Reifier_info.decl h.Reifier_info.body) ]
+        | rs ->
+            let mutual_names = List.map rs ~f:(fun { Reifier_info.decl } -> decl.ptype_name.txt) in
+            let mutual_args ~loc e =
+              pexp_fun
                 ~loc
-                (List.map mutual_names ~f:(fun name -> ppat_var ~loc (Located.mk ~loc name))))
-             e
-         in
-         List.concat
-           [ List.map rs ~f:(fun { Reifier_info.name; decl; body } ->
-                 let loc = decl.ptype_loc in
-                 let pat = ppat_var ~loc (Located.mk ~loc name) in
-                 value_binding ~loc ~pat ~expr:(mutual_args ~loc @@ add_args decl body))
-           ; List.concat_map rs ~f:(fun _ -> [])
-           ]
-   ;;
+                nolabel
+                None
+                (ppat_tuple
+                   ~loc
+                   (List.map mutual_names ~f:(fun name -> ppat_var ~loc (Located.mk ~loc name))))
+                e
+            in
+            List.concat
+              [ List.map rs ~f:(fun { Reifier_info.name; decl; body } ->
+                    let loc = decl.ptype_loc in
+                    let pat = ppat_var ~loc (Located.mk ~loc name) in
+                    value_binding ~loc ~pat ~expr:(mutual_args ~loc @@ add_args decl body))
+              ; List.concat_map rs ~f:(fun _ -> [])
+              ]
+      ;;
 *)

ppx/wildcard/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppx_wildcard)
+ (public_name OCanren-ppx.ppx_wildcard)
+ (kind ppx_rewriter)
+ (libraries base ppxlib)
+ (modules ppx_wildcard)
+ (preprocess
+  (pps ppxlib.metaquot)))

ppx/wildcard/ppx_wildcard.ml

@@ -0,0 +1,123 @@
+(*
+ * OCanren. PPX syntax extensions.
+ * Copyright (C) 2015-2023
+ * Dmitri Boulytchev, Dmitry Kosarev, Alexey Syomin, Evgeny Moiseenko
+ * St.Petersburg State University, JetBrains Research
+ *
+ * This software is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License version 2, as published by the Free Software Foundation.
+ *
+ * This software is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * See the GNU Library General Public License version 2 for more details
+ * (enclosed in the file COPYING).
+ *)
+
+(** This extension performs expansion of wildcards in:
+
+  {ul {- Unification
+         {[ (q === __ % __) ]} to {[ Fresh.two (fun __1 __2 -> q === __1 % __2) ]}
+      }
+      {- Disequality
+          {[ (q =/= Std.List.cons __ __) ]}
+             to
+          {[ wc (fun __1 -> wc (fun __2 -> q =/= Std.List.cons __1 __2)) ]}
+      }
+  }
+ *)
+
+open Ppxlib
+open Ppxlib.Ast_helper
+
+let name_of_loc loc =
+  (* Format.printf "name_of_loc: %a\n%!" Location.print loc; *)
+  let start = loc.Location.loc_start in
+  (* let mangled_fname =
+    String.map start.pos_fname ~f:(function
+        | '.' -> '_'
+        | c -> c)
+  in *)
+  let mangled_fname = start.pos_fname in
+  Printf.sprintf "__%s_c%d" mangled_fname Lexing.(start.pos_cnum - start.pos_bol)
+;;
+
+let wildcard_extractor expr =
+  let folder =
+    object
+      inherit [_] Ppxlib.Ast_traverse.fold_map as super
+
+      method! expression e acc =
+        (* Format.printf "wildcard_extractor: %a\n%!" Pprintast.expression e; *)
+        let open Ppxlib.Ast_pattern in
+        let loc = e.pexp_loc in
+        let on_OK =
+          let open Ppxlib.Ast_builder.Default in
+          pexp_ident ~loc (Located.mk ~loc (Lident (name_of_loc e.pexp_loc)))
+        in
+        parse
+          (pexp_ident (lident (string "__")))
+          loc
+          e
+          (on_OK, e.pexp_loc :: acc)
+          ~on_error:(fun () -> super#expression e acc)
+    end
+  in
+  folder#expression expr []
+;;
+
+type kind =
+  | Unif
+  | Diseq
+
+let mapper =
+  object
+    inherit Ast_traverse.map as super
+
+    method! expression e =
+      (* Format.printf "%a\n%!" Pprintast.expression  e; *)
+      let loc = e.pexp_loc in
+      let pat =
+        let open Ppxlib.Ast_pattern in
+        pexp_apply
+          (pexp_ident (lident (string "===")))
+          ((nolabel ** __) ^:: (nolabel ** __) ^:: nil)
+        |> map2 ~f:(fun a b -> Unif, a, b)
+        ||| (pexp_apply
+               (pexp_ident (lident (string "=/=")))
+               ((nolabel ** __) ^:: (nolabel ** __) ^:: nil)
+            |> map2 ~f:(fun a b -> Diseq, a, b))
+      in
+      let on_unif (kind, l, r) =
+        let l, accl = wildcard_extractor l in
+        let r, accr = wildcard_extractor r in
+        let f acc loc =
+          let open Ppxlib.Ast_builder.Default in
+          let name = name_of_loc loc in
+          let name_expr = pexp_constant ~loc (Pconst_string (name, loc, None)) in
+          let pat = ppat_var ~loc (Located.mk ~loc name) in
+          let nameless = true in
+          let make_wc, make_fresh =
+            if nameless
+            then [%expr wc], [%expr call_fresh]
+            else [%expr named_wc [%e name_expr]], [%expr named_fresh [%e name_expr]]
+          in
+          match kind with
+          | Diseq -> [%expr [%e make_wc] (fun [%p pat] -> [%e acc])]
+          | Unif -> [%expr [%e make_fresh] (fun [%p pat] -> [%e acc])]
+        in
+        let init =
+          match kind with
+          | Unif -> [%expr [%e l] === [%e r]]
+          | Diseq -> [%expr [%e l] =/= [%e r]]
+        in
+        let ans1 = ListLabels.fold_left ~f ~init accr in
+        ListLabels.fold_left ~f ~init:ans1 accl
+      in
+      Ppxlib.Ast_pattern.parse pat loc e on_unif ~on_error:(fun () -> super#expression e)
+  end
+;;
+
+let () = Ppxlib.Driver.register_transformation ~impl:mapper#structure "ppx_wildcard"

regression/test002.t

@@ -1,7 +1,7 @@
   $ ./test002sort.exe
-  [O; O; _.138]
-  [O; O; _.136 [=/= O]]
-  [O; O; _.153 [=/= O]]
+  [O; O; _.140]
+  [O; O; _.140 [=/= O]]
+  [O; O; _.157 [=/= O]]
   [O; S (O); S (_.497)]
   [O; S (O); S (_.516 [=/= O])]
   [O; S (O); S (_.110)]

regression/test005.t

@@ -19,14 +19,14 @@
   q=[("x", V ("y")) | _.13];
   }
   fun q -> infero (abs varX (v varX)) q, 1 answer {
-  q=Arr (_.18, _.18);
+  q=Arr (_.21, _.21);
   }
   fun q -> infero (abs varF (abs varX (app (v varF) (v varX)))) q, 1 answer {
-  q=Arr (Arr (_.30, _.26), Arr (_.30, _.26));
+  q=Arr (Arr (_.54, _.26), Arr (_.54, _.26));
   }
   fun q -> infero (abs varX (abs varF (app (v varF) (v varX)))) q, 1 answer {
-  q=Arr (_.30, Arr (Arr (_.30, _.26), _.26));
+  q=Arr (_.64, Arr (Arr (_.64, _.26), _.26));
   }
   fun q -> infero q (arr (p varX) (p varX)), 1 answer {
-  q=Abs (_.29, V (_.29));
+  q=Abs (_.30, V (_.30));
   }

regression/test006.t

@@ -24,10 +24,10 @@
   q=V ("x");
   }
   fun q -> evalo (app q (v varX)) (v varX), 1 answer {
-  q=Abs (_.44, V (_.44));
+  q=Abs (_.59, V (_.59));
   }
   fun q r -> evalo (app r q) (v varX), 1 answer {
-  q=V ("x"); r=Abs (_.54, V (_.54));
+  q=V ("x"); r=Abs (_.68, V (_.68));
   }
   fun q r s -> a_la_quine q r s, 2 answers {
   q=Abs (_.668, V (_.668)); r=Abs (_.668, V (_.668)); s=Abs (_.668, V (_.668));

regression/test011.t

@@ -174,7 +174,7 @@
   fun q ->
     OCanren.Fresh.two
       (fun x y -> delay (fun () -> conj (!![x; y] === q) (y =/= x))), all answers {
-  q=[_.11; _.12 [=/= _.11]];
+  q=[_.11 [=/= _.12]; _.12];
   }
   fun q ->
     OCanren.Fresh.two
@@ -247,7 +247,7 @@
   fun x ->
     OCanren.Fresh.two
       (fun y z -> delay (fun () -> conj (x =/= !![y; !2]) (x === !![z; !2]))), all answers {
-  q=[_.12 [=/= _.11]; 2];
+  q=[_.12; 2];
   }
   fun q -> distincto (!2 % (!3 %< q)), all answers {
   q=_.35 [=/= 2; =/= 3];

regression/test014.t

@@ -28,18 +28,18 @@
   q=[_.13 | _.14]; r=[]; s=[];
   q=[1]; r=[_.15 | _.16]; s=[_.15 | _.16];
   q=[_.17; _.18 | _.19]; r=[1]; s=[_.17; _.18 | _.19];
-  q=[0; 1]; r=[_.28; _.33 | _.34]; s=[0; _.28; _.33 | _.34];
-  q=[0; 0; 1]; r=[_.69; _.76 | _.77]; s=[0; 0; _.69; _.76 | _.77];
+  q=[0; 1]; r=[_.43; _.33 | _.34]; s=[0; _.43; _.33 | _.34];
+  q=[0; 0; 1]; r=[_.97; _.76 | _.77]; s=[0; 0; _.97; _.76 | _.77];
   q=[1; _.102 | _.103]; r=[0; 1]; s=[0; 1; _.102 | _.103];
-  q=[0; 0; 0; 1]; r=[_.149; _.164 | _.165]; s=[0; 0; 0; _.149; _.164 | _.165];
+  q=[0; 0; 0; 1]; r=[_.207; _.164 | _.165]; s=[0; 0; 0; _.207; _.164 | _.165];
   q=[1; _.192 | _.193]; r=[0; 0; 1]; s=[0; 0; 1; _.192 | _.193];
   q=[0; 1; _.218 | _.219]; r=[0; 1]; s=[0; 0; 1; _.218 | _.219];
-  q=[0; 0; 0; 0; 1]; r=[_.314; _.343 | _.344]; s=[0; 0; 0; 0; _.314; _.343 | _.344];
+  q=[0; 0; 0; 0; 1]; r=[_.437; _.343 | _.344]; s=[0; 0; 0; 0; _.437; _.343 | _.344];
   q=[1; _.375 | _.376]; r=[0; 0; 0; 1]; s=[0; 0; 0; 1; _.375 | _.376];
   q=[0; 1; _.401 | _.402]; r=[0; 0; 1]; s=[0; 0; 0; 1; _.401 | _.402];
   q=[0; 0; 1; _.459 | _.460]; r=[0; 1]; s=[0; 0; 0; 1; _.459 | _.460];
   q=[1; 1]; r=[1; 1]; s=[1; 0; 0; 1];
-  q=[0; 0; 0; 0; 0; 1]; r=[_.656; _.713 | _.714]; s=[0; 0; 0; 0; 0; _.656; _.713 | _.714];
+  q=[0; 0; 0; 0; 0; 1]; r=[_.904; _.713 | _.714]; s=[0; 0; 0; 0; 0; _.904; _.713 | _.714];
   q=[1; _.745 | _.746]; r=[0; 0; 0; 0; 1]; s=[0; 0; 0; 0; 1; _.745 | _.746];
   q=[0; 1; _.778 | _.779]; r=[0; 0; 0; 1]; s=[0; 0; 0; 0; 1; _.778 | _.779];
   q=[0; 0; 1; _.834 | _.835]; r=[0; 0; 1]; s=[0; 0; 0; 0; 1; _.834 | _.835];
@@ -48,7 +48,7 @@
   q=[0; 1; 1]; r=[1; 1]; s=[0; 1; 0; 0; 1];
   q=[1; 1]; r=[1; 1; 1]; s=[1; 0; 1; 0; 1];
   q=[1; 1]; r=[0; 1; 1]; s=[0; 1; 0; 0; 1];
-  q=[0; 0; 0; 0; 0; 0; 1]; r=[_.1360; _.1493 | _.1494]; s=[0; 0; 0; 0; 0; 0; _.1360; _.1493 | _.1494];
+  q=[0; 0; 0; 0; 0; 0; 1]; r=[_.1860; _.1493 | _.1494]; s=[0; 0; 0; 0; 0; 0; _.1860; _.1493 | _.1494];
   q=[1; _.1523 | _.1524]; r=[0; 0; 0; 0; 0; 1]; s=[0; 0; 0; 0; 0; 1; _.1523 | _.1524];
   q=[0; 1; _.1553 | _.1554]; r=[0; 0; 0; 0; 1]; s=[0; 0; 0; 0; 0; 1; _.1553 | _.1554];
   q=[0; 0; 1; _.1607 | _.1608]; r=[0; 0; 0; 1]; s=[0; 0; 0; 0; 0; 1; _.1607 | _.1608];
@@ -64,11 +64,11 @@
   q=[1]; r=[0; 1];
   q=[0; 1]; r=[0; 0; 1];
   q=[1; 1]; r=[0; 1; 1];
-  q=[1; _.225; 1]; r=[0; 1; _.225; 1];
+  q=[1; _.653; 1]; r=[0; 1; _.653; 1];
   q=[0; 0; 1]; r=[0; 0; 0; 1];
   q=[0; 1; 1]; r=[0; 0; 1; 1];
-  q=[1; _.247; _.408; 1]; r=[0; 1; _.247; _.408; 1];
-  q=[0; 1; _.408; 1]; r=[0; 0; 1; _.408; 1];
+  q=[1; _.1001; _.408; 1]; r=[0; 1; _.1001; _.408; 1];
+  q=[0; 1; _.1243; 1]; r=[0; 0; 1; _.1243; 1];
   q=[0; 0; 0; 1]; r=[0; 0; 0; 0; 1];
   }
   fun q r -> lelo q r, 15 answers {

regression_ppx/dune

@@ -134,11 +134,6 @@
  (modules test012mutual)
  (package OCanren)
  (public_names -)
- (flags
-  (:standard
-   ;-dsource
-   ;
-   ))
  (preprocess
   (pps OCanren-ppx.ppx_distrib GT.ppx_all -- -new-typenames -pretty))
  (libraries OCanren OCanren.tester))
@@ -175,17 +170,27 @@
  (libraries OCanren OCanren.tester))
 
 (executables
- (names test015diseq)
- (modules test015diseq)
+ (names test015mutual)
+ (modules test015mutual)
+ (package OCanren)
+ (public_names -)
+ (preprocess
+  (pps OCanren-ppx.ppx_distrib GT.ppx_all -- -new-typenames -pretty))
+ (libraries OCanren OCanren.tester))
+
+(executables
+ (names test016diseq)
+ (modules test016diseq)
  (package OCanren)
  (public_names -)
  (preprocess
   (pps
+   OCanren-ppx.ppx_distrib
    OCanren-ppx.ppx_fresh
-   OCanren-ppx.ppx_deriving_reify
-   GT.ppx_all
    OCanren-ppx.ppx_repr
+   GT.ppx_all
    --
+   -new-typenames
    -pretty))
  (libraries OCanren OCanren.tester))
 
@@ -331,5 +336,14 @@
  (deps
   (package OCanren-ppx)
   %{project_root}/ppx/pp_ocanren_all.exe
-  test015diseq.ml
-  test015diseq.exe))
+  test015mutual.ml
+  test015mutual.exe))
+
+(cram
+ (package OCanren)
+ (applies_to test016)
+ (deps
+  (package OCanren-ppx)
+  %{project_root}/ppx/pp_ocanren_all.exe
+  test016diseq.ml
+  test016diseq.exe))