Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
grew
libcaml-grew
Commits
9f5fbb31
Commit
9f5fbb31
authored
Jun 21, 2017
by
Bruno Guillaume
Browse files
Change domain structure (it is possible to have only a feature domain or a label domain)
parent
c1cbbc95
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/grew_domain.ml
View file @
9f5fbb31
...
...
@@ -34,6 +34,8 @@ module Label_domain = struct
(** The [default] style value *)
let
default
=
{
text
=
"UNSET"
;
bottom
=
false
;
color
=
None
;
bgcolor
=
None
;
line
=
Solid
}
let
merge
t1
t2
=
failwith
"TODO"
(** [decl] is the type for a label declaration: the name and a list of display styles *)
type
decl
=
string
*
string
list
...
...
@@ -119,6 +121,8 @@ module Feature_domain = struct
let
feature_names
feature_domain
=
List
.
map
(
function
Ast
.
Closed
(
fn
,
_
)
|
Ast
.
Open
fn
|
Ast
.
Num
fn
->
fn
)
feature_domain
let
merge
t1
t2
=
failwith
"TODO"
let
get
feature_name
feature_domain
=
List
.
find
(
function
|
Ast
.
Closed
(
fn
,_
)
when
fn
=
feature_name
->
true
...
...
@@ -169,45 +173,53 @@ end (* Feature_domain *)
(* ================================================================================ *)
module
Domain
=
struct
type
t
=
Label_domain
.
t
*
Feature_domain
.
t
type
t
=
|
Both
of
Label_domain
.
t
*
Feature_domain
.
t
|
Label
of
Label_domain
.
t
|
Feature
of
Feature_domain
.
t
let
build
ld
fd
=
(
ld
,
fd
)
let
build
ld
fd
=
Both
(
ld
,
fd
)
let
build_features_only
fd
=
Feature
fd
let
build_labels_only
ld
=
Label
ld
let
build_disj
?
loc
?
domain
name
unsorted_values
=
match
domain
with
|
Some
(
_
,
feature_domain
)
->
Feature_domain
.
build_disj
?
loc
~
feature_domain
name
unsorted_values
|
None
->
Feature_domain
.
build_disj
?
loc
name
unsorted_values
|
Some
(
Feature
feature_domain
)
|
Some
(
Both
(
_
,
feature_domain
))
->
Feature_domain
.
build_disj
?
loc
~
feature_domain
name
unsorted_values
|
_
->
Feature_domain
.
build_disj
?
loc
name
unsorted_values
let
feature_names
(
_
,
feature_domain
)
=
Feature_domain
.
feature_names
feature_domain
let
feature_names
=
function
|
Feature
feature_domain
|
Both
(
_
,
feature_domain
)
->
Feature_domain
.
feature_names
feature_domain
|
_
->
[]
let
get_label_name
?
domain
index
=
match
domain
with
|
Some
((
names
,_
)
,_
)
->
Some
names
.
(
index
)
|
None
->
None
|
Some
(
Both
((
names
,_
)
,_
)
)
|
Some
(
Label
(
names
,_
))
->
Some
names
.
(
index
)
|
_
->
None
let
get_label_style
?
domain
index
=
match
domain
with
|
Some
((
_
,
styles
)
,_
)
->
Some
styles
.
(
index
)
|
None
->
None
|
Some
(
Both
((
_
,
styles
)
,_
)
)
|
Some
(
Label
(
_
,
styles
))
->
Some
styles
.
(
index
)
|
_
->
None
let
edge_id_from_string
?
loc
?
domain
str
=
match
domain
with
|
Some
((
names
,_
)
,_
)
->
|
Some
(
Both
((
names
,_
)
,_
)
)
|
Some
(
Label
(
names
,_
))
->
begin
try
Some
(
Id
.
build
?
loc
str
names
)
with
Not_found
->
Error
.
build
"[Domain.edge_id_from_string] unknown edge label '%s'"
str
end
|
None
->
None
|
_
->
None
let
is_open_feature
?
domain
name
=
match
domain
with
|
Some
(
_
,
feature_domain
)
->
Feature_domain
.
is_open
feature_domain
name
|
None
->
true
|
Some
(
Feature
feature_domain
)
|
Some
(
Both
(
_
,
feature_domain
)
)
->
Feature_domain
.
is_open
feature_domain
name
|
_
->
true
let
check_feature
?
loc
?
domain
name
value
=
match
domain
with
|
Some
(
_
,
feature_domain
)
->
Feature_domain
.
check_feature
?
loc
~
feature_domain
name
value
|
None
->
()
|
Some
(
Feature
feature_domain
)
|
Some
(
Both
(
_
,
feature_domain
)
)
->
Feature_domain
.
check_feature
?
loc
~
feature_domain
name
value
|
_
->
()
let
check_feature_name
?
loc
?
domain
name
=
match
domain
with
|
None
->
()
|
Some
(
_
,
feature_domain
)
->
|
Some
(
Feature
feature_domain
)
|
Some
(
Both
(
_
,
feature_domain
))
->
if
not
(
Feature_domain
.
is_defined
name
feature_domain
)
then
Error
.
build
?
loc
"The feature name
\"
%s
\"
in not defined in the domain"
name
|
_
->
()
end
src/grew_domain.mli
View file @
9f5fbb31
...
...
@@ -27,6 +27,8 @@ module Label_domain : sig
type
decl
=
string
*
string
list
val
build
:
decl
list
->
t
val
merge
:
t
->
t
->
t
end
(* ================================================================================ *)
...
...
@@ -38,6 +40,7 @@ module Feature_domain: sig
(** [sub domain fn1 fn2] returns [true] iff the domain of [fn1] is a subset if the domain of [fn2]. *)
val
sub
:
t
->
feature_name
->
feature_name
->
bool
val
merge
:
t
->
t
->
t
end
(* module Feature_domain *)
(* ================================================================================ *)
...
...
@@ -45,7 +48,8 @@ module Domain : sig
type
t
val
build
:
Label_domain
.
t
->
Feature_domain
.
t
->
t
val
build_features_only
:
Feature_domain
.
t
->
t
val
build_labels_only
:
Label_domain
.
t
->
t
val
build_disj
:
?
loc
:
Loc
.
t
->
?
domain
:
t
->
feature_name
->
...
...
src/grew_grs.ml
View file @
9f5fbb31
...
...
@@ -602,29 +602,37 @@ module New_grs = struct
decls
:
decl
list
;
ast
:
New_ast
.
grs
;
}
(*
let load_decl file =
let ast = Loader.new_grs file in
List.map (fun
)
let load file =
let ast = Loader.new_grs file in
match ast with
| *)
let
load
filename
=
let
ast
=
Loader
.
new_grs
filename
in
let
feature_domains
=
List_
.
opt_map
(
fun
x
->
match
x
with
|
New_ast
.
Features
desc
->
Some
desc
|
New_ast
.
Features
desc
->
Some
(
Feature_domain
.
build
desc
)
|
_
->
None
)
ast
in
let
feature_domain
=
match
feature_domains
with
|
[]
->
None
|
h
::
t
->
Some
(
List
.
fold_left
Feature_domain
.
merge
h
t
)
in
let
label_domains
=
List_
.
opt_map
(
fun
x
->
match
x
with
|
New_ast
.
Labels
desc
->
Some
(
Label_domain
.
build
desc
)
|
_
->
None
)
ast
in
let
label_domain
=
match
label_domains
with
|
[]
->
None
|
h
::
t
->
Some
(
List
.
fold_left
Label_domain
.
merge
h
t
)
in
let
domain
=
match
(
label_domain
,
feature_domain
)
with
|
(
None
,
None
)
->
None
|
(
Some
ld
,
None
)
->
Some
(
Domain
.
build_labels_only
ld
)
|
(
None
,
Some
fd
)
->
Some
(
Domain
.
build_features_only
fd
)
|
(
Some
ld
,
Some
fd
)
->
Some
(
Domain
.
build
ld
fd
)
in
{
filename
;
ast
;
domain
=
None
;
domain
;
decls
=
[]
;
}
end
src/libgrew.ml
View file @
9f5fbb31
...
...
@@ -60,14 +60,14 @@ module Domain = struct
Grew_grs
.
Grs
.
domain_build
ast
let
load
filename
=
handle
~
name
:
"
feature_names
"
handle
~
name
:
"
Domain.load
"
(
fun
()
->
let
ast
=
Grew_loader
.
Loader
.
domain
filename
in
Grew_grs
.
Grs
.
domain_build
ast
)
()
let
feature_names
domain
=
handle
~
name
:
"feature_names"
handle
~
name
:
"
Domain.
feature_names"
(
fun
()
->
Grew_domain
.
Domain
.
feature_names
domain
)
()
end
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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