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
L
libcaml-grew
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
3
Issues
3
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
grew
libcaml-grew
Commits
e86ca5d2
Commit
e86ca5d2
authored
Dec 04, 2017
by
Bruno Guillaume
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
code rewriting
parent
40b093d0
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
63 additions
and
65 deletions
+63
-65
src/grew_command.ml
src/grew_command.ml
+57
-59
src/grew_rule.ml
src/grew_rule.ml
+6
-6
No files found.
src/grew_command.ml
View file @
e86ca5d2
...
...
@@ -20,9 +20,9 @@ open Grew_fs
(* ================================================================================ *)
module
Command
=
struct
type
command_node
=
(* a command node is either: *)
|
Pat
of
Pid
.
t
(* a node identified in the pattern *)
|
New
of
string
(* a node introduced by a new_neighbour *)
(* TODO: remov
e *)
type
command_node
=
(* a command node is either: *)
|
Pat
of
Pid
.
t
(* a node identified in the pattern *)
|
New
of
string
(* a node introduced by a add_nod
e *)
let
command_node_to_json
=
function
|
Pat
pid
->
`String
(
Pid
.
to_string
pid
)
...
...
@@ -55,11 +55,11 @@ module Command = struct
|
ADD_EDGE_EXPL
of
(
command_node
*
command_node
*
string
)
|
DEL_FEAT
of
(
command_node
*
string
)
|
UPDATE_FEAT
of
(
command_node
*
string
*
item
list
)
(* *)
|
NEW_NODE
of
string
|
NEW_BEFORE
of
(
string
*
command_node
)
|
NEW_AFTER
of
(
string
*
command_node
)
(* *)
|
SHIFT_EDGE
of
(
command_node
*
command_node
*
Label_cst
.
t
)
|
SHIFT_IN
of
(
command_node
*
command_node
*
Label_cst
.
t
)
|
SHIFT_OUT
of
(
command_node
*
command_node
*
Label_cst
.
t
)
...
...
@@ -172,18 +172,16 @@ module Command = struct
|
H_SHIFT_OUT
of
(
Gid
.
t
*
Gid
.
t
)
let
build
?
domain
?
param
(
kai
,
kei
)
table
ast_command
=
(* kai stands for "known act ident", kei for "known edge ident" *)
let
pid_of_act_id
loc
node_name
=
try
(* TODO: remove with activate *)
Pat
(
Pid
.
Pos
(
Id
.
build
~
loc
node_name
table
))
with
_
->
New
node_name
in
let
build
?
domain
?
param
(
kni
,
kei
)
table
ast_command
=
(* kni stands for "known node idents", kei for "known edge idents" *)
let
pid_of_node_id
loc
node_id
=
Pat
(
Pid
.
Pos
(
Id
.
build
~
loc
node_id
table
))
in
let
cn_of_node_id
node_id
=
match
Id
.
build_opt
node_id
table
with
|
Some
x
->
Pat
(
Pid
.
Pos
x
)
|
None
->
New
node_id
in
let
check_node_id
loc
node_id
k
a
i
=
if
not
(
List
.
mem
node_id
k
a
i
)
let
check_node_id
loc
node_id
k
n
i
=
if
not
(
List
.
mem
node_id
k
n
i
)
then
Error
.
build
~
loc
"Unbound node identifier
\"
%s
\"
"
node_id
in
(* check that the edge_id is defined in the pattern *)
...
...
@@ -192,78 +190,78 @@ module Command = struct
then
Error
.
build
~
loc
"Unbound edge identifier
\"
%s
\"
"
edge_id
in
match
ast_command
with
|
(
Ast
.
Del_edge_expl
(
act_i
,
act
_j
,
lab
)
,
loc
)
->
check_node_id
loc
act_i
ka
i
;
check_node_id
loc
act_j
ka
i
;
|
(
Ast
.
Del_edge_expl
(
node_i
,
node
_j
,
lab
)
,
loc
)
->
check_node_id
loc
node_i
kn
i
;
check_node_id
loc
node_j
kn
i
;
let
edge
=
G_edge
.
make
~
loc
?
domain
lab
in
((
DEL_EDGE_EXPL
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
edge
)
,
loc
)
,
(
ka
i
,
kei
))
((
DEL_EDGE_EXPL
(
cn_of_node_id
node_i
,
cn_of_node_id
node_j
,
edge
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
Del_edge_name
id
,
loc
)
->
check_edge
loc
id
kei
;
(
DEL_EDGE_NAME
id
,
loc
)
,
(
k
a
i
,
List_
.
rm
id
kei
)
(
DEL_EDGE_NAME
id
,
loc
)
,
(
k
n
i
,
List_
.
rm
id
kei
)
|
(
Ast
.
Add_edge
(
act_i
,
act
_j
,
lab
)
,
loc
)
->
check_node_id
loc
act_i
ka
i
;
check_node_id
loc
act_j
ka
i
;
|
(
Ast
.
Add_edge
(
node_i
,
node
_j
,
lab
)
,
loc
)
->
check_node_id
loc
node_i
kn
i
;
check_node_id
loc
node_j
kn
i
;
let
edge
=
G_edge
.
make
~
loc
?
domain
lab
in
((
ADD_EDGE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
edge
)
,
loc
)
,
(
ka
i
,
kei
))
((
ADD_EDGE
(
cn_of_node_id
node_i
,
cn_of_node_id
node_j
,
edge
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
Add_edge_expl
(
act_i
,
act
_j
,
name
)
,
loc
)
->
check_node_id
loc
act_i
ka
i
;
check_node_id
loc
act_j
ka
i
;
((
ADD_EDGE_EXPL
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
name
)
,
loc
)
,
(
ka
i
,
kei
))
|
(
Ast
.
Add_edge_expl
(
node_i
,
node
_j
,
name
)
,
loc
)
->
check_node_id
loc
node_i
kn
i
;
check_node_id
loc
node_j
kn
i
;
((
ADD_EDGE_EXPL
(
cn_of_node_id
node_i
,
cn_of_node_id
node_j
,
name
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
Shift_edge
(
act_i
,
act
_j
,
label_cst
)
,
loc
)
->
check_node_id
loc
act_i
ka
i
;
check_node_id
loc
act_j
ka
i
;
((
SHIFT_EDGE
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
Label_cst
.
build
~
loc
?
domain
label_cst
)
,
loc
)
,
(
ka
i
,
kei
))
|
(
Ast
.
Shift_edge
(
node_i
,
node
_j
,
label_cst
)
,
loc
)
->
check_node_id
loc
node_i
kn
i
;
check_node_id
loc
node_j
kn
i
;
((
SHIFT_EDGE
(
cn_of_node_id
node_i
,
cn_of_node_id
node_j
,
Label_cst
.
build
~
loc
?
domain
label_cst
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
Shift_in
(
act_i
,
act
_j
,
label_cst
)
,
loc
)
->
check_node_id
loc
act_i
ka
i
;
check_node_id
loc
act_j
ka
i
;
((
SHIFT_IN
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
Label_cst
.
build
?
domain
~
loc
label_cst
)
,
loc
)
,
(
ka
i
,
kei
))
|
(
Ast
.
Shift_in
(
node_i
,
node
_j
,
label_cst
)
,
loc
)
->
check_node_id
loc
node_i
kn
i
;
check_node_id
loc
node_j
kn
i
;
((
SHIFT_IN
(
cn_of_node_id
node_i
,
cn_of_node_id
node_j
,
Label_cst
.
build
?
domain
~
loc
label_cst
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
Shift_out
(
act_i
,
act
_j
,
label_cst
)
,
loc
)
->
check_node_id
loc
act_i
ka
i
;
check_node_id
loc
act_j
ka
i
;
((
SHIFT_OUT
(
pid_of_act_id
loc
act_i
,
pid_of_act_id
loc
act_j
,
Label_cst
.
build
?
domain
~
loc
label_cst
)
,
loc
)
,
(
ka
i
,
kei
))
|
(
Ast
.
Shift_out
(
node_i
,
node
_j
,
label_cst
)
,
loc
)
->
check_node_id
loc
node_i
kn
i
;
check_node_id
loc
node_j
kn
i
;
((
SHIFT_OUT
(
cn_of_node_id
node_i
,
cn_of_node_id
node_j
,
Label_cst
.
build
?
domain
~
loc
label_cst
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
New_node
new_id
,
loc
)
->
if
List
.
mem
new_id
k
a
i
if
List
.
mem
new_id
k
n
i
then
Error
.
build
~
loc
"Node identifier
\"
%s
\"
is already used"
new_id
;
(((
NEW_NODE
new_id
)
,
loc
)
,
(
new_id
::
k
a
i
,
kei
))
(((
NEW_NODE
new_id
)
,
loc
)
,
(
new_id
::
k
n
i
,
kei
))
|
(
Ast
.
New_before
(
new_id
,
old_id
)
,
loc
)
->
check_node_id
loc
old_id
k
a
i
;
if
List
.
mem
new_id
k
a
i
check_node_id
loc
old_id
k
n
i
;
if
List
.
mem
new_id
k
n
i
then
Error
.
build
~
loc
"Node identifier
\"
%s
\"
is already used"
new_id
;
((
NEW_BEFORE
(
new_id
,
pid_of_act_id
loc
old_id
)
,
loc
)
,
(
new_id
::
ka
i
,
kei
))
((
NEW_BEFORE
(
new_id
,
cn_of_node_id
old_id
)
,
loc
)
,
(
new_id
::
kn
i
,
kei
))
|
(
Ast
.
New_after
(
new_id
,
old_id
)
,
loc
)
->
check_node_id
loc
old_id
k
a
i
;
if
List
.
mem
new_id
k
a
i
check_node_id
loc
old_id
k
n
i
;
if
List
.
mem
new_id
k
n
i
then
Error
.
build
~
loc
"Node identifier
\"
%s
\"
is already used"
new_id
;
((
NEW_AFTER
(
new_id
,
pid_of_act_id
loc
old_id
)
,
loc
)
,
(
new_id
::
ka
i
,
kei
))
((
NEW_AFTER
(
new_id
,
cn_of_node_id
old_id
)
,
loc
)
,
(
new_id
::
kn
i
,
kei
))
|
(
Ast
.
Del_node
act
_n
,
loc
)
->
check_node_id
loc
act_n
ka
i
;
((
DEL_NODE
(
pid_of_act_id
loc
act_n
)
,
loc
)
,
(
List_
.
rm
act_n
ka
i
,
kei
))
|
(
Ast
.
Del_node
node
_n
,
loc
)
->
check_node_id
loc
node_n
kn
i
;
((
DEL_NODE
(
cn_of_node_id
node_n
)
,
loc
)
,
(
List_
.
rm
node_n
kn
i
,
kei
))
|
(
Ast
.
Del_feat
(
act
_id
,
feat_name
)
,
loc
)
->
|
(
Ast
.
Del_feat
(
node
_id
,
feat_name
)
,
loc
)
->
if
feat_name
=
"position"
then
Error
.
build
~
loc
"Illegal del_feat command: the 'position' feature cannot be deleted"
;
check_node_id
loc
act_id
ka
i
;
check_node_id
loc
node_id
kn
i
;
Domain
.
check_feature_name
~
loc
?
domain
feat_name
;
((
DEL_FEAT
(
pid_of_act_id
loc
act_id
,
feat_name
)
,
loc
)
,
(
ka
i
,
kei
))
((
DEL_FEAT
(
cn_of_node_id
node_id
,
feat_name
)
,
loc
)
,
(
kn
i
,
kei
))
|
(
Ast
.
Update_feat
((
act
_id
,
feat_name
)
,
ast_items
)
,
loc
)
->
check_node_id
loc
act_id
ka
i
;
|
(
Ast
.
Update_feat
((
node
_id
,
feat_name
)
,
ast_items
)
,
loc
)
->
check_node_id
loc
node_id
kn
i
;
let
items
=
List
.
map
(
function
|
Ast
.
Qfn_item
(
node_id
,
feature_name
)
->
check_node_id
loc
node_id
k
a
i
;
check_node_id
loc
node_id
k
n
i
;
Domain
.
check_feature_name
~
loc
?
domain
feature_name
;
Feat
(
pid_of_node_id
loc
node_id
,
feature_name
)
Feat
(
cn_of_node_id
node_id
,
feature_name
)
|
Ast
.
String_item
s
->
String
s
|
Ast
.
Param_item
var
->
match
param
with
...
...
@@ -281,6 +279,6 @@ module Command = struct
|
[
String
s
]
->
Domain
.
check_feature
~
loc
?
domain
feat_name
s
|
[
Feat
(
_
,
fn
)]
->
()
|
_
->
Error
.
build
~
loc
"[Update_feat] Only open features can be modified with the concat operator '+' but
\"
%s
\"
is not declared as an open feature"
feat_name
);
((
UPDATE_FEAT
(
pid_of_act_id
loc
act_id
,
feat_name
,
items
)
,
loc
)
,
(
ka
i
,
kei
))
((
UPDATE_FEAT
(
cn_of_node_id
node_id
,
feat_name
,
items
)
,
loc
)
,
(
kn
i
,
kei
))
end
(* module Command *)
src/grew_rule.ml
View file @
e86ca5d2
...
...
@@ -464,21 +464,21 @@ module Rule = struct
(* ====================================================================== *)
let
build_commands
?
domain
?
param
pos
pos_table
ast_commands
=
let
known_
act
_ids
=
Array
.
to_list
pos_table
in
let
known_
node
_ids
=
Array
.
to_list
pos_table
in
let
known_edge_ids
=
get_edge_ids
pos
in
let
rec
loop
(
k
a
i
,
kei
)
=
function
let
rec
loop
(
k
n
i
,
kei
)
=
function
|
[]
->
[]
|
ast_command
::
tail
->
let
(
command
,
(
new_k
a
i
,
new_kei
))
=
let
(
command
,
(
new_k
n
i
,
new_kei
))
=
Command
.
build
?
domain
?
param
(
k
a
i
,
kei
)
(
k
n
i
,
kei
)
pos_table
ast_command
in
command
::
(
loop
(
new_k
a
i
,
new_kei
)
tail
)
in
loop
(
known_
act
_ids
,
known_edge_ids
)
ast_commands
command
::
(
loop
(
new_k
n
i
,
new_kei
)
tail
)
in
loop
(
known_
node
_ids
,
known_edge_ids
)
ast_commands
(* ====================================================================== *)
let
parse_vars
loc
vars
=
...
...
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