add “to_json” functions

_tags

-true:	package(unix, conll, dep2pict, camomile, cairo2, log)
+true:	package(unix, conll, dep2pict, camomile, cairo2, log, yojson)
 true: bin_annot

src/grew_edge.ml

@@ -77,6 +77,18 @@ module Label_cst = struct
     | Neg l -> "^"^(List_.to_string (Label.to_string ?domain) "|" l)
     | Regexp (_,re) -> "re\""^re^"\""
 
+  let to_json ?domain = function
+  | Pos l -> `Assoc
+    ["pos",
+      `List (List.map (fun lab -> `String (Label.to_string ?domain lab)) l)
+    ]
+  | Neg l -> `Assoc
+      ["neg",
+        `List (List.map (fun lab -> `String (Label.to_string ?domain lab)) l)
+      ]
+  | Regexp (_,re) -> `Assoc
+      ["regexp", `String re]
+
   let all = Neg []
 
   let match_ ?domain cst g_label = match cst with
@@ -130,6 +142,12 @@ module P_edge = struct
 
   let get_id t = t.id
 
+  let to_json ?domain t =
+    `Assoc [
+      ("edge_id", `String t.id);
+      ("label_cst", Label_cst.to_json ?domain t.label_cst)
+    ]
+
   let build ?domain (ast_edge, loc) =
     { id = (match ast_edge.Ast.edge_id with Some s -> s | None -> fresh_name ());
       label_cst = Label_cst.build ~loc ?domain ast_edge.Ast.edge_label_cst

src/grew_edge.mli

@@ -42,6 +42,7 @@ module Label_cst : sig
   | Regexp of (Str.regexp * string)
 
   val to_string: ?domain:Domain.t -> t -> string
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
   val all: t
   val match_: ?domain:Domain.t -> t -> Label.t -> bool
   val build: ?loc:Loc.t -> ?domain:Domain.t -> Ast.edge_label_cst -> t
@@ -74,6 +75,8 @@ module P_edge: sig
   (* [all] is the joker pattern edge *)
   val all: t
 
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
+
   val get_id: t -> string
 
   val to_string: ?domain:Domain.t -> t -> string

src/grew_fs.ml

@@ -98,6 +98,16 @@ module P_feature = struct
     printf "in_param=[%s]\n" (String.concat "," (List.map string_of_int in_param));
     printf "%!"
 
+  let to_json ?domain (feature_name, {cst}) =
+    `Assoc [
+      ("feature_name", `String feature_name);
+      ( match cst with
+        | Absent -> ("absent", `Null)
+        | Equal val_list -> ("equal", `List (List.map (fun x -> `String (string_of_value x)) val_list))
+        | Different val_list -> ("different", `List (List.map (fun x -> `String (string_of_value x)) val_list))
+      )
+    ]
+
   let get_name = fst
 
   let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
@@ -368,6 +378,8 @@ module P_fs = struct
 
   let empty = []
 
+  let to_json ?domain t = `List (List.map (P_feature.to_json ?domain) t)
+
   let check_position ?param position t =
     try
       match List.assoc "position" t with

src/grew_fs.mli

@@ -73,6 +73,8 @@ end (* module G_fs *)
 module P_fs: sig
   type t
 
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
+
   val empty: t
 
   val build: ?domain:Domain.t -> ?pat_vars: string list -> Ast.feature list -> t

src/grew_graph.ml

@@ -40,6 +40,17 @@ module P_graph = struct
 
   let pid_name_list t = Pid_map.fold (fun _ node acc -> (P_node.get_name node)::acc) t []
 
+  let to_json ?domain t =
+    `List (
+      Pid_map.fold
+        (fun pid p_node acc ->
+          (`Assoc [
+            ("id", `String (Pid.to_string pid));
+            ("node", P_node.to_json ?domain p_node)
+          ]) :: acc
+        ) t []
+      )
+
   (* -------------------------------------------------------------------------------- *)
   let map_add_edge map id_src label id_tar =
     let node_src =

src/grew_graph.mli

@@ -45,6 +45,8 @@ module P_graph: sig
 
   val empty: t
 
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
+
   val find: Pid.t -> t -> P_node.t
 
   val roots: t -> Pid.t list

src/grew_grs.ml

@@ -159,6 +159,13 @@ module Modul = struct
     loc: Loc.t;
   }
 
+  let to_json ?domain t =
+    `Assoc [
+      ("module_name", `String t.name);
+      ("confluent", `Bool t.confluent);
+      ("rules", `List (List.map (Rule.to_json ?domain) t.rules));
+    ]
+
   let check t =
     (* check for duplicate rules *)
     let rec loop already_defined = function
@@ -196,6 +203,8 @@ module Grs = struct
     ast: Ast.grs;
   }
 
+  let to_json t = `List (List.map Modul.to_json t.modules)
+
   let get_modules t = t.modules
   let get_ast t = t.ast
   let get_filename t = t.filename

src/grew_grs.mli

@@ -76,6 +76,8 @@ module Modul: sig
     confluent: bool;
     loc: Loc.t;
   }
+
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
 end (* module Modul *)
 
 (* ================================================================================ *)
@@ -111,4 +113,6 @@ module Grs: sig
   val filter_iter: (string -> Rule.t -> unit) -> t -> unit
 
 (*  val modules_of_sequence: t -> string -> Modul.t list*)
+
+  val to_json: t -> Yojson.Basic.json
 end (* module Grs *)

src/grew_node.ml

@@ -129,6 +129,22 @@ module P_node = struct
       loc: Loc.t option;
     }
 
+  let to_json ?domain t =
+    let json_next = `List (
+      Massoc_pid.fold
+        (fun acc pid p_edge ->
+          `Assoc [
+            ("id", `String (Pid.to_string pid));
+            ("label", P_edge.to_json ?domain p_edge);
+          ] :: acc
+        ) [] t.next
+    ) in
+    `Assoc [
+      ("node_name", `String t.name);
+      ("fs", P_fs.to_json ?domain t.fs);
+      ("next", json_next)
+    ]
+
   let get_name t = t.name
   let get_fs t = t.fs
   let get_next t = t.next

src/grew_node.mli

@@ -86,6 +86,8 @@ module P_node: sig
 
   val empty: t
 
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
+
   val get_name: t -> Id.name
   val get_fs: t -> P_fs.t
   val get_next: t -> P_edge.t Massoc_pid.t

src/grew_rule.ml

@@ -88,23 +88,125 @@ module Rule = struct
     | Cst_in of Pid.t * Label_cst.t
     | Feature_eq of Pid.t * string * Pid.t * string
     | Feature_diseq of Pid.t * string * Pid.t * string
-
+    (* *)
     | Feature_cst of Pid.t * string * string
     | Feature_diff_cst of Pid.t * string * string
-
+    (* *)
     | Feature_float of Pid.t * string * float
     | Feature_diff_float of Pid.t * string * float
-
+    (* *)
     | Feature_re of Pid.t * string * string
-
+    (* *)
     | Feature_ineq of Ast.ineq * Pid.t * string * Pid.t * string
     | Feature_ineq_cst of Ast.ineq * Pid.t * string * float
-
+    (* *)
     | Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match basic *)
-
+    (* *)
     | Prec of Pid.t * Pid.t
     | Lprec of Pid.t * Pid.t
 
+  let const_to_json ?domain = function
+  | Cst_out (pid, label_cst) -> `Assoc ["cst_out", Label_cst.to_json ?domain label_cst]
+  | Cst_in (pid, label_cst) -> `Assoc ["cst_in", Label_cst.to_json ?domain label_cst]
+  | Feature_eq (pid1,fn1,pid2,fn2) ->
+    `Assoc ["features_eq",
+      `Assoc [
+        ("id1", `String (Pid.to_string pid1));
+        ("feature_name_1", `String fn1);
+        ("id2", `String (Pid.to_string pid2));
+        ("feature_name_2", `String fn2);
+      ]
+    ]
+  | Feature_diseq (pid1,fn1,pid2,fn2) ->
+    `Assoc ["features_diseq",
+      `Assoc [
+        ("id1", `String (Pid.to_string pid1));
+        ("feature_name_1", `String fn1);
+        ("id2", `String (Pid.to_string pid2));
+        ("feature_name_2", `String fn2);
+      ]
+    ]
+  | Feature_cst (pid,fn,value) ->
+    `Assoc ["feature_eq_cst",
+      `Assoc [
+        ("id", `String (Pid.to_string pid));
+        ("feature_name_", `String fn);
+        ("value", `String value);
+      ]
+    ]
+  | Feature_diff_cst (pid,fn,value) ->
+    `Assoc ["feature_diseq_cst",
+      `Assoc [
+        ("id", `String (Pid.to_string pid));
+        ("feature_name_", `String fn);
+        ("value", `String value);
+      ]
+    ]
+  | Feature_float (pid,fn,value) ->
+    `Assoc ["feature_eq_float",
+      `Assoc [
+        ("id", `String (Pid.to_string pid));
+        ("feature_name_", `String fn);
+        ("value", `String (string_of_float value));
+        ]
+    ]
+  | Feature_diff_float (pid,fn,value) ->
+    `Assoc ["feature_diff_float",
+      `Assoc [
+        ("id", `String (Pid.to_string pid));
+        ("feature_name", `String fn);
+        ("value", `String (string_of_float value));
+      ]
+    ]
+  | Feature_re (pid,fn,regexp) ->
+    `Assoc ["feature_eq_regexp",
+      `Assoc [
+        ("id", `String (Pid.to_string pid));
+        ("feature_name", `String fn);
+        ("regexp", `String regexp);
+      ]
+    ]
+  | Feature_ineq (ineq,pid1,fn1,pid2,fn2) ->
+    `Assoc ["features_ineq",
+      `Assoc [
+        ("ineq", `String (Ast.string_of_ineq ineq));
+        ("id1", `String (Pid.to_string pid1));
+        ("feature_name_1", `String fn1);
+        ("id2", `String (Pid.to_string pid2));
+        ("feature_name_2", `String fn2);
+      ]
+    ]
+  | Feature_ineq_cst (ineq,pid,fn,value) ->
+    `Assoc ["feature_ineq_cst",
+      `Assoc [
+        ("ineq", `String (Ast.string_of_ineq ineq));
+        ("id", `String (Pid.to_string pid));
+        ("feature_name", `String fn);
+        ("value", `String (string_of_float value));
+      ]
+    ]
+  | Filter (pid, p_fs) ->
+    `Assoc ["filter",
+      `Assoc [
+        ("id", `String (Pid.to_string pid));
+        ("fs", P_fs.to_json ?domain p_fs);
+      ]
+    ]
+  | Prec (pid1, pid2) ->
+    `Assoc ["immediate_prec",
+      `Assoc [
+        ("id1", `String (Pid.to_string pid1));
+        ("id2", `String (Pid.to_string pid2));
+      ]
+    ]
+  | Lprec (pid1, pid2) ->
+    `Assoc ["large_prec",
+      `Assoc [
+        ("id1", `String (Pid.to_string pid1));
+        ("id2", `String (Pid.to_string pid2));
+      ]
+    ]
+
   let build_pos_constraint ?domain pos_table const =
     let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
     match const with
@@ -161,6 +263,12 @@ module Rule = struct
     constraints: const list;
   }
 
+  let basic_to_json ?domain basic =
+    `Assoc [
+      ("graph", P_graph.to_json ?domain basic.graph);
+      ("constraints", `List (List.map (const_to_json ?domain) basic.constraints));
+    ]
+
   let build_pos_basic ?domain ?pat_vars ?(locals=[||]) basic_ast =
     let (graph, pos_table) =
       P_graph.build ?domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
@@ -275,6 +383,15 @@ module Rule = struct
 
   let is_filter t = t.commands = []
 
+  let to_json ?domain t =
+    match t.param with
+    | None -> `Assoc [
+      ("rule_name", `String t.name);
+      ("match", basic_to_json ?domain (fst t.pattern));
+      ("without", `List (List.map (basic_to_json ?domain) (snd t.pattern)));
+    ]
+    | Some _ -> Error.build "Rule.to_json undefined for parametrized rules"
+
   (* ====================================================================== *)
   let to_dep ?domain t =
     let pos_basic = fst t.pattern in

src/grew_rule.mli

@@ -78,6 +78,8 @@ module Rule : sig
   (** [is_filter t] returns [true] iff the rule [t] is a filter rule. *)
   val is_filter: t -> bool
 
+  val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
+
   (** [to_dep t] returns a string in the [dep] language describing the match basic of the rule *)
   val to_dep: ?domain:Domain.t -> t -> string
 

src/libgrew.ml

@@ -263,6 +263,10 @@ module Grs = struct
       ) ()
 
   let get_domain grs = Grew_grs.Grs.get_domain grs
+
+  let to_json t =
+    let json = Grew_grs.Grs.to_json t in
+    Yojson.Basic.pretty_to_string json
 end
 
 (* ==================================================================================================== *)

src/libgrew.mli

@@ -123,6 +123,8 @@ module Grs: sig
   val build_html_doc: ?corpus:bool -> string -> t -> unit
 
   val get_domain: t -> Domain.t option
+
+  val to_json: t -> string
 end
 
 (* ==================================================================================================== *)