Change domain structure (it is possible to have only a feature domain or a label domain)

src/grew_domain.ml

@@ -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

@@ -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

@@ -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

@@ -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