Commit bad2793f authored by POTTIER Francois's avatar POTTIER Francois

Work in progress on [MLPatternExample].

parent a807e559
......@@ -394,3 +394,5 @@ class virtual ['self] iter2 = object (_ : 'self)
inherit [_] VisitorsRuntime.unit_monoid
method private restrict _ _ () = ()
end
open MLPatternExample (* TEMPORARY work in progress *)
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
*)
......@@ -6,3 +6,6 @@ true: \
<*.ml>: \
for-pack(AlphaLib)
<MLPatternExample.*>: \
package(visitors.ppx)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment