grew_command.ml 9.92 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
Bruno Guillaume's avatar
Bruno Guillaume committed
4
(*    Copyright 2011-2018 Inria, Université de Lorraine                           *)
bguillaum's avatar
bguillaum committed
5
(*                                                                                *)
Bruno Guillaume's avatar
Bruno Guillaume committed
6
(*    Webpage: http://grew.fr                                                     *)
bguillaum's avatar
bguillaum committed
7 8 9 10
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11 12 13
open Printf
open Log

14
open Grew_base
15
open Grew_types
16
open Grew_domain
bguillaum's avatar
bguillaum committed
17
open Grew_ast
pj2m's avatar
pj2m committed
18
open Grew_edge
bguillaum's avatar
bguillaum committed
19
open Grew_fs
pj2m's avatar
pj2m committed
20

bguillaum's avatar
bguillaum committed
21
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
22
module Command  = struct
Bruno Guillaume's avatar
Bruno Guillaume committed
23 24 25
  type command_node =   (* a command node is either: *)
    | Pat of Pid.t      (* a node identified in the pattern *)
    | New of string     (* a node introduced by a add_node *)
pj2m's avatar
pj2m committed
26

27 28 29 30
  let command_node_to_json = function
    | Pat pid -> `String (Pid.to_string pid)
    | New s -> `String s

bguillaum's avatar
bguillaum committed
31
  (* [item] is a element of the RHS of an update_feat command *)
32
  type item =
33
    | Feat of (command_node * string)
34
    | String of string
35
    | Lexical_field of (string * string)
36

37 38 39 40 41 42 43 44
  let item_to_json = function
  | Feat (cn, feature_name) -> `Assoc [("copy_feat",
        `Assoc [
          ("node",command_node_to_json cn);
          ("feature_name", `String feature_name);
        ]
      )]
  | String s -> `Assoc [("string", `String s)]
45
  | Lexical_field (lex,field) -> `Assoc [("lexical_filed", `String (lex ^ "." ^ field))]
46

pj2m's avatar
pj2m committed
47
  (* the command in pattern *)
bguillaum's avatar
bguillaum committed
48
  type p =
49 50
    | DEL_NODE of command_node
    | DEL_EDGE_EXPL of (command_node * command_node * G_edge.t)
pj2m's avatar
pj2m committed
51
    | DEL_EDGE_NAME of string
52
    | ADD_EDGE of (command_node * command_node * G_edge.t)
53
    | ADD_EDGE_EXPL of (command_node * command_node * string)
54 55
    | DEL_FEAT of (command_node * string)
    | UPDATE_FEAT of (command_node * string * item list)
Bruno Guillaume's avatar
Bruno Guillaume committed
56
    (* *)
bguillaum's avatar
bguillaum committed
57 58 59
    | NEW_NODE of string
    | NEW_BEFORE of (string * command_node)
    | NEW_AFTER of (string * command_node)
Bruno Guillaume's avatar
Bruno Guillaume committed
60
    (* *)
61 62 63
    | SHIFT_EDGE of (command_node * command_node * Label_cst.t)
    | SHIFT_IN of (command_node * command_node * Label_cst.t)
    | SHIFT_OUT of (command_node * command_node * Label_cst.t)
pj2m's avatar
pj2m committed
64 65 66

  type t = p * Loc.t  (* remember command location to be able to localize a command failure *)

67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
  let to_json ?domain (p, _) = match p with
  | DEL_NODE cn -> `Assoc [("del_node", command_node_to_json cn)]
  | DEL_EDGE_EXPL (src,tar,edge) ->
    `Assoc [("del_edge_expl",
      `Assoc [
        ("src",command_node_to_json src);
        ("tar",command_node_to_json tar);
        ("edge", G_edge.to_json ?domain edge);
      ]
    )]
  | DEL_EDGE_NAME edge_name -> `Assoc [("del_edge_name", `String edge_name)]
  | ADD_EDGE (src,tar,edge) ->
    `Assoc [("add_edge",
      `Assoc [
        ("src",command_node_to_json src);
        ("tar",command_node_to_json tar);
        ("edge", G_edge.to_json ?domain edge);
      ]
    )]

87 88 89 90 91 92 93 94 95
    | ADD_EDGE_EXPL (src,tar,name) ->
      `Assoc [("add_edge",
        `Assoc [
          ("src",command_node_to_json src);
          ("tar",command_node_to_json tar);
          ("name", `String name);
        ]
      )]

96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
  | DEL_FEAT (cn, feature_name) ->
    `Assoc [("del_feat",
      `Assoc [
        ("node",command_node_to_json cn);
        ("feature_name", `String feature_name);
      ]
    )]

  | UPDATE_FEAT (cn, feature_name, items) ->
    `Assoc [("update_feat",
      `Assoc [
        ("node",command_node_to_json cn);
        ("feature_name", `String feature_name);
        ("items", `List (List.map item_to_json items));
      ]
    )]

  | NEW_NODE name -> `Assoc [("new_node", `String name)]
  | NEW_BEFORE (name, cn) ->
    `Assoc [("new_before",
      `Assoc [
        ("name", `String name);
        ("node", command_node_to_json cn);
      ]
    )]
  | NEW_AFTER (name, cn) ->
    `Assoc [("new_after",
      `Assoc [
        ("name", `String name);
        ("node", command_node_to_json cn);
      ]
    )]

  | SHIFT_EDGE (src,tar,label_cst) ->
      `Assoc [("shift_edge",
        `Assoc [
          ("src",command_node_to_json src);
          ("tar",command_node_to_json tar);
          ("label_cst", Label_cst.to_json ?domain label_cst);
        ]
      )]
  | SHIFT_IN (src,tar,label_cst) ->
      `Assoc [("shift_in",
        `Assoc [
          ("src",command_node_to_json src);
          ("tar",command_node_to_json tar);
          ("label_cst", Label_cst.to_json ?domain label_cst);
        ]
      )]
  | SHIFT_OUT (src,tar,label_cst) ->
      `Assoc [("shift_out",
        `Assoc [
          ("src",command_node_to_json src);
          ("tar",command_node_to_json tar);
          ("label_cst", Label_cst.to_json ?domain label_cst);
        ]
      )]

154
  let build ?domain lexicons (kni, kei) table ast_command =
Bruno Guillaume's avatar
Bruno Guillaume committed
155
    (* kni stands for "known node idents", kei for "known edge idents" *)
156

Bruno Guillaume's avatar
Bruno Guillaume committed
157 158 159 160
    let cn_of_node_id node_id =
      match Id.build_opt node_id table with
      | Some x -> Pat (Pid.Pos x)
      | None   -> New node_id in
161

162
    let check_node_id_msg loc msg node_id kni =
Bruno Guillaume's avatar
Bruno Guillaume committed
163
      if not (List.mem node_id kni)
164 165 166
      then Error.build ~loc "%s \"%s\"" msg node_id in

    let check_node_id loc node_id kni = check_node_id_msg loc "Unbound node identifier" node_id kni in
167

bguillaum's avatar
bguillaum committed
168
    (* check that the edge_id is defined in the pattern *)
bguillaum's avatar
bguillaum committed
169 170
    let check_edge loc edge_id kei =
      if not (List.mem edge_id kei)
171 172
      then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in

pj2m's avatar
pj2m committed
173
    match ast_command with
Bruno Guillaume's avatar
Bruno Guillaume committed
174 175 176
      | (Ast.Del_edge_expl (node_i, node_j, lab), loc) ->
          check_node_id loc node_i kni;
          check_node_id loc node_j kni;
177
          let edge = G_edge.from_string ~loc ?domain lab in
Bruno Guillaume's avatar
Bruno Guillaume committed
178
          ((DEL_EDGE_EXPL (cn_of_node_id node_i, cn_of_node_id node_j, edge), loc), (kni, kei))
bguillaum's avatar
bguillaum committed
179

180
      | (Ast.Del_edge_name id, loc) ->
bguillaum's avatar
bguillaum committed
181
          check_edge loc id kei;
Bruno Guillaume's avatar
Bruno Guillaume committed
182
          (DEL_EDGE_NAME id, loc), (kni, List_.rm id kei)
pj2m's avatar
pj2m committed
183

Bruno Guillaume's avatar
Bruno Guillaume committed
184 185 186
      | (Ast.Add_edge (node_i, node_j, lab), loc) ->
          check_node_id loc node_i kni;
          check_node_id loc node_j kni;
187
          let edge = G_edge.from_string ~loc ?domain lab in
Bruno Guillaume's avatar
Bruno Guillaume committed
188
          ((ADD_EDGE (cn_of_node_id node_i, cn_of_node_id node_j, edge), loc), (kni, kei))
189

Bruno Guillaume's avatar
Bruno Guillaume committed
190 191 192 193
      | (Ast.Add_edge_expl (node_i, node_j, name), loc) ->
          check_node_id loc node_i kni;
          check_node_id loc node_j kni;
          ((ADD_EDGE_EXPL (cn_of_node_id node_i, cn_of_node_id node_j, name), loc), (kni, kei))
194

Bruno Guillaume's avatar
Bruno Guillaume committed
195 196 197 198
      | (Ast.Shift_edge (node_i, node_j, label_cst), loc) ->
          check_node_id loc node_i kni;
          check_node_id loc node_j kni;
          ((SHIFT_EDGE (cn_of_node_id node_i, cn_of_node_id node_j, Label_cst.build ~loc ?domain label_cst), loc), (kni, kei))
199

Bruno Guillaume's avatar
Bruno Guillaume committed
200 201 202 203
      | (Ast.Shift_in (node_i, node_j, label_cst), loc) ->
          check_node_id loc node_i kni;
          check_node_id loc node_j kni;
          ((SHIFT_IN (cn_of_node_id node_i, cn_of_node_id node_j, Label_cst.build ?domain ~loc label_cst), loc), (kni, kei))
204

Bruno Guillaume's avatar
Bruno Guillaume committed
205 206 207 208
      | (Ast.Shift_out (node_i, node_j, label_cst), loc) ->
          check_node_id loc node_i kni;
          check_node_id loc node_j kni;
          ((SHIFT_OUT (cn_of_node_id node_i, cn_of_node_id node_j, Label_cst.build ?domain ~loc label_cst), loc), (kni, kei))
209

bguillaum's avatar
bguillaum committed
210
      | (Ast.New_node new_id, loc) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
211
          if List.mem new_id kni
bguillaum's avatar
bguillaum committed
212
          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
Bruno Guillaume's avatar
Bruno Guillaume committed
213
          (((NEW_NODE new_id), loc),(new_id::kni, kei))
bguillaum's avatar
bguillaum committed
214 215

      | (Ast.New_before (new_id, old_id), loc) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
216 217
          check_node_id loc old_id kni;
          if List.mem new_id kni
bguillaum's avatar
bguillaum committed
218
          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
Bruno Guillaume's avatar
Bruno Guillaume committed
219
          ((NEW_BEFORE (new_id,cn_of_node_id old_id), loc),(new_id::kni, kei))
bguillaum's avatar
bguillaum committed
220 221

      | (Ast.New_after (new_id, old_id), loc) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
222 223
          check_node_id loc old_id kni;
          if List.mem new_id kni
bguillaum's avatar
bguillaum committed
224
          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
Bruno Guillaume's avatar
Bruno Guillaume committed
225
          ((NEW_AFTER (new_id,cn_of_node_id old_id), loc),(new_id::kni, kei))
bguillaum's avatar
bguillaum committed
226

Bruno Guillaume's avatar
Bruno Guillaume committed
227 228 229
      | (Ast.Del_node node_n, loc) ->
          check_node_id loc node_n kni;
          ((DEL_NODE (cn_of_node_id node_n), loc), (List_.rm node_n kni, kei))
bguillaum's avatar
bguillaum committed
230

Bruno Guillaume's avatar
Bruno Guillaume committed
231
      | (Ast.Del_feat (node_id, feat_name), loc) ->
bguillaum's avatar
bguillaum committed
232 233
          if feat_name = "position"
          then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
Bruno Guillaume's avatar
Bruno Guillaume committed
234
          check_node_id loc node_id kni;
bguillaum's avatar
bguillaum committed
235
          Domain.check_feature_name ~loc ?domain feat_name;
Bruno Guillaume's avatar
Bruno Guillaume committed
236
          ((DEL_FEAT (cn_of_node_id node_id, feat_name), loc), (kni, kei))
bguillaum's avatar
bguillaum committed
237

Bruno Guillaume's avatar
Bruno Guillaume committed
238 239
      | (Ast.Update_feat ((node_id, feat_name), ast_items), loc) ->
          check_node_id loc node_id kni;
bguillaum's avatar
bguillaum committed
240 241
          let items = List.map
            (function
242
              | Ast.Qfn_or_lex_item (node_id_or_lex,feature_name_or_lex_field) ->
Bruno Guillaume's avatar
Bruno Guillaume committed
243 244 245 246 247 248
                if List.mem_assoc node_id_or_lex lexicons
                then
                  begin
                    Lexicons.check ~loc node_id_or_lex feature_name_or_lex_field lexicons;
                    Lexical_field (node_id_or_lex, feature_name_or_lex_field)
                  end
249 250
                else
                  begin
Bruno Guillaume's avatar
Bruno Guillaume committed
251
                    check_node_id_msg loc ("Unbound identifier (neither a node nor a lexicon):") node_id_or_lex kni;
252 253 254
                    Domain.check_feature_name ~loc ?domain feature_name_or_lex_field;
                    Feat (cn_of_node_id node_id_or_lex, feature_name_or_lex_field)
                  end
bguillaum's avatar
bguillaum committed
255 256
              | Ast.String_item s -> String s
            ) ast_items in
257 258
            (* check for consistency *)
            (match items with
bguillaum's avatar
bguillaum committed
259 260
              | _ when Domain.is_open_feature ?domain feat_name -> ()
              | [String s] -> Domain.check_feature ~loc ?domain feat_name s
261
              | _ -> ());
Bruno Guillaume's avatar
Bruno Guillaume committed
262
          ((UPDATE_FEAT (cn_of_node_id node_id, feat_name, items), loc), (kni, kei))
bguillaum's avatar
bguillaum committed
263

264
end (* module Command *)