grew_command.ml 7.88 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3 4 5 6 7 8 9 10
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
(*    Copyright 2011-2013 Inria, Université de Lorraine                           *)
(*                                                                                *)
(*    Webpage: http://grew.loria.fr                                               *)
(*    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

bguillaum's avatar
bguillaum committed
14
open Grew_base
15 16
open Grew_types

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
23
  type command_node =        (* a command node is either: *)
24
    | Pat of Pid.t           (* a node identified in the pattern *)
bguillaum's avatar
bguillaum committed
25 26
    | New of string          (* a node introduced by a new_neighbour *) (* TODO: remove *)
    | Act of Pid.t * string  (* a node introduced by an activate *)
pj2m's avatar
pj2m committed
27

bguillaum's avatar
bguillaum committed
28
  (* [item] is a element of the RHS of an update_feat command *)
29
  type item =
30
    | Feat of (command_node * string)
31
    | String of string
bguillaum's avatar
bguillaum committed
32 33
    | Param_in of int
    | Param_out of int
34

pj2m's avatar
pj2m committed
35
  (* the command in pattern *)
bguillaum's avatar
bguillaum committed
36
  type p =
37 38
    | DEL_NODE of command_node
    | DEL_EDGE_EXPL of (command_node * command_node * G_edge.t)
pj2m's avatar
pj2m committed
39
    | DEL_EDGE_NAME of string
40 41 42
    | ADD_EDGE of (command_node * command_node * G_edge.t)
    | DEL_FEAT of (command_node * string)
    | UPDATE_FEAT of (command_node * string * item list)
bguillaum's avatar
bguillaum committed
43
    | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) (* TODO: remove *)
44 45 46 47
    | SHIFT_EDGE of (command_node * command_node)
    | SHIFT_IN of (command_node * command_node)
    | SHIFT_OUT of (command_node * command_node)
    | MERGE_NODE of (command_node * command_node)
bguillaum's avatar
bguillaum committed
48 49
    | ACT_NODE of command_node

pj2m's avatar
pj2m committed
50 51 52 53

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

  (* a item in the command history: command applied to a graph *)
bguillaum's avatar
bguillaum committed
54
  type h =
55
    | H_DEL_NODE of Gid.t
bguillaum's avatar
bguillaum committed
56
    | H_DEL_EDGE_EXPL of (Gid.t * Gid.t * G_edge.t)
pj2m's avatar
pj2m committed
57
    | H_DEL_EDGE_NAME of string
58 59 60
    | H_ADD_EDGE of (Gid.t * Gid.t * G_edge.t)
    | H_DEL_FEAT of (Gid.t * string)
    | H_UPDATE_FEAT of (Gid.t * string * string)
bguillaum's avatar
bguillaum committed
61
    | H_NEW_NEIGHBOUR of (string * G_edge.t * Gid.t) (* TODO: remove *)
62 63 64 65
    | H_SHIFT_EDGE of (Gid.t * Gid.t)
    | H_SHIFT_IN of (Gid.t * Gid.t)
    | H_SHIFT_OUT of (Gid.t * Gid.t)
    | H_MERGE_NODE of (Gid.t * Gid.t)
bguillaum's avatar
bguillaum committed
66
    | H_ACT_NODE of (Gid.t * string)
67

68
  let build ?param (kai, kei) table locals suffixes ast_command =
bguillaum's avatar
bguillaum committed
69
    (* kai stands for "known act ident", kei for "known edge ident" *)
70

71 72 73 74 75 76
    let pid_of_act_id loc = function
        | (node_name, Some n) -> Act (Pid.Pos (Id.build ~loc node_name table), n)
        | (node_name, None) ->
          try  (* TODO: remove with activate *)
            Pat (Pid.Pos (Id.build ~loc node_name table))
          with _ -> New node_name in
77

bguillaum's avatar
bguillaum committed
78
    (* check that an act_id is well-defined earlier *)
79 80 81
    let check_act_id loc act_id kai =
      if not (List.mem act_id kai)
      then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) in
82

bguillaum's avatar
bguillaum committed
83
    (* check that the edge_id is defined in the pattern *)
bguillaum's avatar
bguillaum committed
84 85
    let check_edge loc edge_id kei =
      if not (List.mem edge_id kei)
86 87
      then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in

pj2m's avatar
pj2m committed
88
    match ast_command with
89
      | (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
bguillaum's avatar
bguillaum committed
90 91 92 93
          check_act_id loc act_i kai;
          check_act_id loc act_j kai;
	        let edge = G_edge.make ~loc ~locals lab in
	        ((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
bguillaum's avatar
bguillaum committed
94

95
      | (Ast.Del_edge_name id, loc) ->
bguillaum's avatar
bguillaum committed
96 97
          check_edge loc id kei;
          (DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
pj2m's avatar
pj2m committed
98

99
      | (Ast.Add_edge (act_i, act_j, lab), loc) ->
bguillaum's avatar
bguillaum committed
100 101 102 103
          check_act_id loc act_i kai;
          check_act_id loc act_j kai;
	        let edge = G_edge.make ~loc ~locals lab in
        	((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
104 105

      | (Ast.Shift_edge (act_i, act_j), loc) ->
bguillaum's avatar
bguillaum committed
106 107 108
          check_act_id loc act_i kai;
          check_act_id loc act_j kai;
	        ((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
109 110

      | (Ast.Shift_in (act_i, act_j), loc) ->
bguillaum's avatar
bguillaum committed
111 112 113
          check_act_id loc act_i kai;
          check_act_id loc act_j kai;
	        ((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
114 115

      | (Ast.Shift_out (act_i, act_j), loc) ->
bguillaum's avatar
bguillaum committed
116 117 118
          check_act_id loc act_i kai;
          check_act_id loc act_j kai;
	        ((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (kai, kei))
119 120

      | (Ast.Merge_node (act_i, act_j), loc) ->
bguillaum's avatar
bguillaum committed
121 122 123
          check_act_id loc act_i kai;
          check_act_id loc act_j kai;
	        ((MERGE_NODE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (List_.rm act_i kai, kei))
124 125

      | (Ast.New_neighbour (new_id, ancestor, label), loc) ->
bguillaum's avatar
bguillaum committed
126 127 128 129 130 131 132
          check_act_id loc ancestor kai;
          if List.mem (new_id, None) kai
          then Error.build ~loc "Node identifier \"%s\" is already used" new_id;

          let edge = G_edge.make ~loc ~locals label in
	        begin
	          try
bguillaum's avatar
bguillaum committed
133 134
            (
              (NEW_NEIGHBOUR
135
                 (new_id,
bguillaum's avatar
bguillaum committed
136
                  edge,
137
                  Pid.Pos (Id.build ~loc (fst ancestor) table)
bguillaum's avatar
bguillaum committed
138
                 ), loc),
139
              ((new_id, None)::kai, kei)
bguillaum's avatar
bguillaum committed
140
            )
bguillaum's avatar
bguillaum committed
141 142 143 144 145 146 147 148
	          with not_found ->
	            Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
	             (G_edge.to_string edge)
	             (fst ancestor)
	             (Loc.to_string loc)
	        end

      | (Ast.Activate act_n, loc) ->
149 150 151 152 153 154 155 156
        begin
          match act_n with
          | (_,None) -> Error.build ~loc "Cannot activate a pattern node"
          | (src, Some suffix) ->
            check_act_id loc (src,None) kai;
            if not (List.mem suffix suffixes) then Error.build ~loc "Undefined suffix \"%s\"" suffix;
            ((ACT_NODE (pid_of_act_id loc act_n), loc), (act_n :: kai, kei))
        end
bguillaum's avatar
bguillaum committed
157

158
      | (Ast.Del_node act_n, loc) ->
bguillaum's avatar
bguillaum committed
159 160
          check_act_id loc act_n kai;
          ((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
bguillaum's avatar
bguillaum committed
161

162
      | (Ast.Del_feat (act_id, feat_name), loc) ->
bguillaum's avatar
bguillaum committed
163 164 165 166
          if feat_name = "position"
          then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
          check_act_id loc act_id kai;
          ((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
bguillaum's avatar
bguillaum committed
167

168
      | (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
bguillaum's avatar
bguillaum committed
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
          check_act_id loc act_id kai;
          let items = List.map
            (function
              (* special case of a basic identifier understood as a string *)
              | Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
              | Ast.Qfn_item ci ->
                let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
                check_act_id loc act_id kai; Feat (pid_of_act_id loc act_id, feature_name)
              | Ast.String_item s -> String s
              | Ast.Param_item var ->
                match param with
                  | None -> Error.build "Unknown command variable '%s'" var
                  | Some (par,cmd) ->
                    match (List_.pos var par, List_.pos var cmd) with
                      | (_,Some index) -> Param_out index
                      | (Some index,_) -> Param_in index
                      | _ -> Error.build "Unknown command variable '%s'" var
            ) ast_items in
          ((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
188
end (* module Command *)