Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
A
alphaLib
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
POTTIER Francois
alphaLib
Commits
bad2793f
Commit
bad2793f
authored
Feb 13, 2017
by
POTTIER Francois
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Work in progress on [MLPatternExample].
parent
a807e559
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
226 additions
and
0 deletions
+226
-0
src/BindingForms.ml
src/BindingForms.ml
+2
-0
src/MLPatternExample.ml
src/MLPatternExample.ml
+221
-0
src/_tags
src/_tags
+3
-0
No files found.
src/BindingForms.ml
View file @
bad2793f
...
...
@@ -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
0 → 100644
View file @
bad2793f
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
View file @
bad2793f
...
...
@@ -6,3 +6,6 @@ true: \
<*.ml>: \
for-pack(AlphaLib)
<MLPatternExample.*>: \
package(visitors.ppx)
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment