Work in progress on [MLPatternExample].

src/BindingForms.ml

@@ -394,3 +394,5 @@ class virtual ['self] iter2 = object (_ : 'self)
   inherit [_] VisitorsRuntime.unit_monoid
   method private restrict _ _ () = ()
 end
+
+open MLPatternExample (* TEMPORARY work in progress *)

src/MLPatternExample.ml

+type 'env mode =
+  | ModeExpression of 'env
+  | ModePattern of 'env ref
+
+let freeze = function
+  | ModeExpression env ->
+      ModeExpression env
+  | ModePattern envref ->
+      ModeExpression !envref
+
+type 't freeze =
+  't
+
+type ('p, 't) bind =
+  'p * 't
+
+class virtual ['self] libmap = object (self : 'self)
+
+  method private virtual extend: 'bn1 -> 'env -> 'bn2 * 'env
+  method private virtual lookup: 'bn1 -> 'env -> 'bn2 (* may be re-routed to [visit_'fn] *)
+
+  method private visit_'bn (mode : 'env mode) (x1 : 'bn1) : 'bn2 =
+    match mode with
+    | ModePattern envref ->
+        let env = !envref in
+        let x2, env = self#extend x1 env in
+        envref := env;
+        x2
+    | ModeExpression env ->
+        self#lookup x1 env
+
+  method private visit_freeze: 'env 't1 't2 .
+    ('env mode -> 't1 -> 't2) ->
+    'env mode -> 't1 -> 't2
+  = fun visit_t mode t1 ->
+    visit_t (freeze mode) t1
+
+  method private visit_bind: 'env 'p1 'p2 't1 't2 .
+    ('env mode -> 'p1 -> 'p2) ->
+    ('env -> 't1 -> 't2) ->
+    'env -> ('p1, 't1) bind -> ('p2, 't2) bind
+  = fun visit_p visit_t env (p1, t1) ->
+      let envref = ref env in
+      let p2 = visit_p (ModePattern envref) p1 in
+      let env = !envref in
+      let t2 = visit_t env t1 in
+      p2, t2
+
+end
+
+type 'bn pat =
+  | PZero
+  | POne
+  | PVar of 'bn
+  | PTuple of 'bn pat list
+  | PConj of 'bn pat * 'bn pat
+  | PDisj of 'bn pat * 'bn pat
+
+and ('bn, 'fn) expr =
+  | EVar of 'fn
+  | EAdd of ('bn, 'fn) expr * ('bn, 'fn) expr
+  | ELet of ('bn pat, ('bn, 'fn) expr) bind
+
+[@@deriving visitors { variety = "map"; ancestors = ["libmap"] }]
+
+  (* The following code is generated:
+  method private visit_pat: 'env mode -> 'bn1 pat -> 'bn2 pat
+  = fun mode pat1 ->
+      match pat1 with
+      | PZero ->
+          PZero
+      | POne ->
+          POne
+      | PVar x1 ->
+          PVar (self#visit_'bn mode x1)
+      | PData (data, pats1) ->
+          PData (data, List.map (self#visit_pat mode) pats1)
+      | PConj (patl1, patr1) ->
+          let patl2 = self#visit_pat mode patl1 in
+          let patr2 = self#visit_pat mode patr1 in
+          PConj (patl2, patr2)
+      | PDisj (patl1, patr1) ->
+          let patl2 = self#visit_pat mode patl1 in
+          let patr2 = self#visit_freeze self#visit_pat mode patr1 in
+          PDisj (patl2, patr2)
+   *)
+
+
+(* ATTIC
+
+type ('bn, 'u) def =
+  'bn pat * 'u
+
+  method private visit_def: 'u1 'u2 .
+    _ ->
+    ('env -> 'u1 -> 'u2) ->
+    'env -> ('bn1, 'u1) def -> ('bn2, 'u2) def
+  = fun _ visit_u env (pat1, u1) ->
+      let envref = ref env in
+      let pat2 = self#visit_pat (ModePattern envref) pat1 in
+      let env = !envref in
+      let u2 = visit_u env u1 in
+      pat2, u2
+
+class virtual ['self] mappat = object (self : 'self)
+
+  method private virtual extend: 'bn1 -> 'env -> 'bn2 * 'env
+  method private virtual lookup: 'bn1 -> 'env -> 'bn2 * 'env
+
+  method private visit_pat: bool -> 'env -> 'bn1 pat -> 'bn2 pat * 'env
+  = fun normal env pat1 ->
+      match pat1 with
+      | PZero ->
+          PZero, env
+      | POne ->
+          POne, env
+      | PVar x1 ->
+          let x2, env = (if normal then self#extend else self#lookup) x1 env in
+          PVar x2, env
+      | PData (data, pats1) ->
+          let pats2, env = self#visit_pats normal env pats1 in
+          PData (data, pats2), env
+      | PConj (patl1, patr1) ->
+          let patl2, env = self#visit_pat normal env patl1 in
+          let patr2, env = self#visit_pat normal env patr1 in
+          PConj (patl2, patr2), env
+      | PDisj (patl1, patr1) ->
+          let patl2, env = self#visit_pat normal env patl1 in
+          let patr2, env = self#visit_pat  false env patr1 in
+          PDisj (patl2, patr2), env
+
+  method private visit_pats: bool -> 'env -> 'bn1 pat list -> 'bn2 pat list * 'env
+  = fun normal env pats1 ->
+      match pats1 with
+      | [] ->
+          [], env
+      | pat1 :: pats1 ->
+          let pat2, env = self#visit_pat normal env pat1 in
+          let pats2, env = self#visit_pats normal env pats1 in
+          pat2 :: pats2, env
+
+  method private visit_def: 'u1 'u2 .
+    _ ->
+    ('env -> 'u1 -> 'u2) ->
+    'env -> ('bn1, 'u1) def -> ('bn2, 'u2) def
+  = fun _ visit_u env (pat1, u1) ->
+      let pat2, env = self#visit_pat true env pat1 in
+      let u2 = visit_u env u1 in
+      pat2, u2
+
+end
+
+class virtual ['self] ba = object (self : 'self)
+
+  method private virtual empty: 'bns
+  method private virtual singleton: 'bn -> 'bns
+  method private virtual union: 'bns -> 'bns -> 'bns
+  method private virtual identical: 'bns -> 'bns -> 'bns
+
+  method private visit_pat: 'bn pat -> 'bns
+  = fun pat ->
+      match pat with
+      | PZero | POne ->
+          self#empty
+      | PVar x ->
+          self#singleton x
+      | PData (_data, pats1) ->
+          List.fold_left (fun bns pat ->
+            self#union bns (self#visit_pat pat)
+          ) self#empty pats1
+      | PConj (pat1, pat2) ->
+          self#union (self#visit_pat pat1) (self#visit_pat pat2)
+      | PDisj (pat1, pat2) ->
+         self#identical (self#visit_pat pat1) (self#visit_pat pat2)
+
+end
+
+class virtual ['self] foo = object (self : 'self)
+
+  inherit [_] mapreduce
+
+  method private virtual empty: 'env
+  method private virtual singleton: 'bn1 -> 'bn2 * 'env
+  method private virtual disjoint_union: 'env -> 'env -> 'env
+  method private virtual identical: 'env -> 'env -> unit
+
+  method private zero = self#empty
+  method private plus = self#disjoint_union
+
+  method private visit_'bn () x =
+    self#singleton x
+
+  method! visit_PDisj () pat1 pat2 =
+    let pat1, env1 = self#visit_pat () pat1 in
+    let pat2, env2 = self#visit_pat () pat2 in
+    self#identical env1 env2;
+      (* should check that the domains are the same *)
+      (* but the images can be different, and if we have already done [map],
+         then we LOSE. *)
+    PDisj (pat1, pat2), env1
+
+end
+
+class virtual ['self] map = object (self : 'self)
+
+  inherit [_] foo
+
+  method private virtual append: 'env -> 'env -> 'env
+
+  method private visit_def: 'u1 'u2 .
+    _ ->
+    ('env -> 'u1 -> 'u2) ->
+    'env -> ('bn1, 'u1) def -> ('bn2, 'u2) def
+  = fun _ visit_u env (pat1, u1) ->
+      let pat2, delta = self#visit_pat () pat1 in
+      let env = self#append env delta in
+      let u2 = visit_u env u1 in
+      pat2, u2
+
+end
+ *)

src/_tags

@@ -6,3 +6,6 @@ true: \
 
 <*.ml>: \
   for-pack(AlphaLib)
+
+<MLPatternExample.*>: \
+  package(visitors.ppx)