Commit 6106f058 authored by Bruno Guillaume's avatar Bruno Guillaume

adapt label_domain to new labels

parent 806136f8
......@@ -323,6 +323,9 @@ module Ast = struct
rule_dir: string option; (* the real folder where the file is defined *)
}
(* [label_spec] is the type for a label declaration: the name and a list of display options *)
type label_spec = string * string list
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
......@@ -342,7 +345,7 @@ module Ast = struct
type domain = {
feature_domain: feature_spec list;
label_domain: (string * string list) list;
label_domain: label_spec list;
}
type gr = {
......
......@@ -186,6 +186,8 @@ module Ast : sig
rule_dir: string option; (* the real folder where the file is defined *)
}
type label_spec = string * string list
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
......@@ -195,7 +197,7 @@ module Ast : sig
type domain = {
feature_domain: feature_spec list;
label_domain: (string * string list) list;
label_domain: label_spec list;
}
type gr = {
......
......@@ -27,19 +27,25 @@ module Label_domain = struct
line: line;
}
let is_void style = (style.text = "void")
(** The [default] style value *)
let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }
type t = style String_map.t
type t = string array * style array
let get_style t str =
try
String_map.find str t
with
| Not_found -> {default with text = str}
let dump (label_array, _) =
let dump label_domain =
Printf.printf "========= Label domain =========\n";
Array.iter (function label -> Printf.printf " - %s\n" label) label_array;
String_map.iter (fun label _ -> Printf.printf " - %s\n" label) label_domain;
Printf.printf "==================================\n%!"
let to_json (labels,_) = `List (List.map (fun x -> `String x) (Array.to_list labels))
let to_json label_domain = `List (String_map.fold (fun k _ acc -> (`String k) :: acc) label_domain [])
(** The [default] style value *)
let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }
(** [decl] is the type for a label declaration: the name and a list of display styles *)
type decl = string * string list
......@@ -76,12 +82,9 @@ module Label_domain = struct
(* [build decl_list] returns a label_domain *)
let build decl_list =
let slist = List.sort (fun (x,_) (y,_) -> compare x y) decl_list in
let (labels, opts) = List.split slist in
let labels_array = Array.of_list labels in
(labels_array,
Array.mapi (fun i opt -> parse_option labels_array.(i) opt) (Array.of_list opts)
)
List.fold_left
(fun acc (label, opts) -> String_map.add label (parse_option label opts) acc
) String_map.empty decl_list
let to_dep ?(deco=false) style =
let dep_items =
......@@ -276,20 +279,8 @@ module Domain = struct
| Feature feature_domain | Both (_, feature_domain) -> Feature_domain.feature_names feature_domain
| _ -> []
let get_label_name ?domain index = match domain with
| Some (Both ((names,_),_)) | Some (Label (names,_)) -> Some names.(index)
| _ -> None
let get_label_style ?domain index = match domain with
| Some (Both ((_,styles),_)) | Some (Label (_,styles))-> Some styles.(index)
| _ -> None
let edge_id_from_string ?loc ?domain str = match domain with
| 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
let get_label_style ?domain str = match domain with
| Some (Both (label_domain,_)) | Some (Label label_domain) -> Some (Label_domain.get_style label_domain str)
| _ -> None
let is_open_feature ?domain name = match domain with
......@@ -309,4 +300,14 @@ module Domain = struct
if not (Feature_domain.is_defined name feature_domain.decls)
then Error.build ?loc "The feature name \"%s\" in not defined in the domain" name
| _ -> ()
let label_to_dot ?domain ?deco label = match domain with
| Some (Both (label_domain,_))
| Some (Label label_domain) -> Label_domain.to_dot ?deco (Label_domain.get_style label_domain label)
| _ -> Label_domain.to_dot ?deco { Label_domain.default with text = label }
let label_to_dep ?domain ?deco label = match domain with
| Some (Both (label_domain,_))
| Some (Label label_domain) -> Label_domain.to_dep ?deco (Label_domain.get_style label_domain label)
| _ -> Label_domain.to_dep ?deco { Label_domain.default with text = label }
end
......@@ -14,23 +14,11 @@ open Grew_ast
(* ================================================================================ *)
module Label_domain : sig
type style
val parse_option: string -> string list -> style
val is_void: style -> bool
val to_dep: ?deco:bool -> style -> string
val to_dot: ?deco:bool -> style -> string
val default: style
type t
(* [decl] is the type for a label declaration: the name and a list of display options *)
type decl = string * string list
val merge: decl list -> decl list -> decl list
val build: decl list -> t
val build: Ast.label_spec list -> t
val merge: Ast.label_spec list -> Ast.label_spec list -> Ast.label_spec list
end
(* ================================================================================ *)
......@@ -62,14 +50,8 @@ module Domain : sig
feature_name ->
feature_atom list -> value list
val feature_names: t -> string list
val get_label_name: ?domain:t -> int -> string option
val get_label_style: ?domain:t -> int -> Label_domain.style option
val edge_id_from_string: ?loc:Loc.t -> ?domain:t -> string -> int option
(** [is_open_feature domain feature_name] returns [true] iff no domain is set or if [feature_name] is defined to be open in the current domain. *)
val is_open_feature: ?domain: t -> feature_name -> bool
......@@ -81,4 +63,8 @@ module Domain : sig
(** [check_feature_name ~loc domain feature_name] fails iff a domain is set and [feature_name] is not defined in the current domain. *)
val check_feature_name: ?loc:Loc.t -> ?domain:t -> feature_name -> unit
val label_to_dot: ?domain:t -> ?deco:bool -> string -> string
val label_to_dep: ?domain:t -> ?deco:bool -> string -> string
end
......@@ -24,10 +24,8 @@ module G_edge = struct
let get_sub = List_.sort_assoc
let to_string ?domain edge =
String.concat "," (List.map (fun (x,y) -> x^"="^y) edge)
exception Not_conll of string
let to_conll ?domain edge =
let rec loop i acc = function
| [] -> acc
......@@ -37,26 +35,22 @@ module G_edge = struct
| (n,v)::t ->
if n = string_of_int i
then loop (i+1) (acc @ [v]) t
else raise (Not_conll (to_string ?domain edge)) in
try String.concat ":" (loop 1 [] edge)
else raise (Not_conll (String.concat "," (List.map (fun (x,y) -> x^"="^y) edge))) in
String.concat ":" (loop 1 [] edge)
let to_string ?domain edge =
try to_conll ?domain edge
with Not_conll s ->
Log.fwarning "[G_edge.to_conll] cannot write conll edge from \"%s\"" s;
s
(* TODO check if useful or remove *)
let is_void ?domain edge = false
let get_style ?domain edge = Label_domain.default
let to_dep ?domain ?(deco=false) t =
let style = get_style ?domain t in
Label_domain.to_dep ~deco style
let conll = to_conll t in
Domain.label_to_dep ?domain ~deco conll
let to_dot ?domain ?(deco=false) t =
let style = get_style ?domain t in
Label_domain.to_dot ~deco style
let to_dep ?domain ?(deco=false) t = sprintf "{ label=\"%s\" }" (to_conll t)
let conll = to_conll t in
Domain.label_to_dot ?domain ~deco conll
let split l = CCList.mapi
(fun i elt -> (string_of_int (i+1), elt)) l
......@@ -146,8 +140,11 @@ module Label_cst = struct
let match_ ?domain cst g_label = match cst with
| Pos labels -> List.exists (fun p_label -> p_label = g_label) labels
| Neg labels -> not (List.exists (fun p_label -> p_label = g_label) labels)
| Regexp (re,_) -> String_.re_match re (G_edge.to_string ?domain g_label)
| Atom_list l -> List.for_all (match_atom g_label) l
| Regexp (re,_) ->
try String_.re_match re (G_edge.to_conll ?domain g_label)
with G_edge.Not_conll s ->
Error.run "Cannot ckeck for regexp constraint on the edge \"%s\"" s
let build_atom = function
| Ast.Atom_eq (name, atoms) -> Eq (name, List.sort Pervasives.compare atoms)
......
......@@ -26,8 +26,6 @@ module G_edge: sig
val get_sub: string -> t -> string option
val is_void: ?domain: Domain.t -> t -> bool
val to_dep: ?domain: Domain.t -> ?deco:bool -> t -> string
val to_dot: ?domain: Domain.t -> ?deco:bool -> t -> string
......@@ -39,8 +37,6 @@ module G_edge: sig
val sub: t
val build: ?domain:Domain.t -> Ast.edge -> t
val is_void: ?domain:Domain.t -> t -> bool
end (* module G_edge *)
......
......@@ -984,10 +984,8 @@ module G_graph = struct
(fun gid elt ->
Massoc_gid.iter
(fun tar g_edge ->
if not (G_edge.is_void ?domain g_edge)
then
let deco = List.mem (gid,g_edge,tar) deco.G_deco.edges in
bprintf buff "N_%s -> N_%s %s\n" (Gid.to_string gid) (Gid.to_string tar) (G_edge.to_dep ?domain ~deco g_edge)
let deco = List.mem (gid,g_edge,tar) deco.G_deco.edges in
bprintf buff "N_%s -> N_%s %s\n" (Gid.to_string gid) (Gid.to_string tar) (G_edge.to_dep ?domain ~deco g_edge)
) (G_node.get_next elt)
) graph.map;
......@@ -1037,7 +1035,7 @@ module G_graph = struct
Massoc_gid.fold
(fun acc2 tar_gid edge ->
let old = try Gid_map.find tar_gid acc2 with Not_found -> [] in
Gid_map.add tar_gid ((sprintf "%g" src_num, G_edge.to_conll ?domain edge)::old) acc2
Gid_map.add tar_gid ((sprintf "%g" src_num, G_edge.to_string ?domain edge)::old) acc2
) acc (G_node.get_next node)
) nodes Gid_map.empty in
......@@ -1103,7 +1101,7 @@ module G_graph = struct
| Ordered f -> int_of_float f
| _ -> Error.run "[G_graph.to_conll] nl_node going to Unordered node" in
let head_proj = CCList.find_map
(fun e -> int_of_string_opt (G_edge.to_conll ?domain e))
(fun e -> int_of_string_opt (G_edge.to_string ?domain e))
(Massoc_gid.assoc head_gid nexts) in
let items = List.fold_left
(fun acc gid ->
......@@ -1111,7 +1109,7 @@ module G_graph = struct
| Ordered f -> int_of_float f
| _ -> Error.run "[G_graph.to_conll] nl_node going to Unordered node" in
let proj = CCList.find_map
(fun e -> int_of_string_opt (G_edge.to_conll ?domain e))
(fun e -> int_of_string_opt (G_edge.to_string ?domain e))
(Massoc_gid.assoc gid nexts) in
Id_with_proj_set.add ((pos,None), proj) acc
) Id_with_proj_set.empty tail_gids in
......
......@@ -40,7 +40,7 @@ let letter = ['a'-'z' 'A'-'Z']
- dot '.'
- colon ':'
- star '*'
The first characted cannot be a digit, or a colon (to avoid confusion).
The first characted cannot be a colon (to avoid confusion).
*)
let label_ident =
(letter | digit | '_' | '-' | '.' | '*') (letter | digit | '_' | '\'' | '-' | '.' | ':' | '*')*
......@@ -115,12 +115,11 @@ and lp_lex name target = parse
LEX_PAR (name, lines)
}
(* The lexer must be different when label_ident are parsed. The [global] lexer calls either
[label_parser] or [standard] depending on the flag [Global.label_flag].
(* The lexer must be different when label_ident are parsed.
The [global] lexer calls either [label_parser] or [standard] depending on the flag [Global.label_flag].
Difference are:
- a label_ident may contain ':' (like in D:suj:obj) and ':' is a token elsewhere
- a label_ident may contain '-' anywhere (like "--" in Tiger) but '-' is fordiden as the first or last character elsewhere
- the string "*" is lexed as ID by [label_parser] and as STAR by [standard]
*)
and global = parse
| "" { if !Global.label_flag
......@@ -251,7 +250,7 @@ and standard target = parse
| ">=" | "≥" { GE }
| '|' { PIPE }
| '/' { SLASH }
| '/' { SLASH }
| "->" { EDGE }
| "-[^" { Global.label_flag := true; LTR_EDGE_LEFT_NEG }
......
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