Commit c7435ab3 authored by Bruno Guillaume's avatar Bruno Guillaume

add “to_json” functions

parent 3f1cd9c1
true: package(unix, conll, dep2pict, camomile, cairo2, log)
true: package(unix, conll, dep2pict, camomile, cairo2, log, yojson)
true: bin_annot
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 =
......
......@@ -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
......
......@@ -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
......
......@@ -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 *)
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
(* ==================================================================================================== *)
......
......@@ -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
(* ==================================================================================================== *)
......
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