Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

grew_ast.ml 9.41 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                                                   *)
(**********************************************************************************)

bguillaum's avatar
bguillaum committed
11
12
open Printf
open Log
bguillaum's avatar
bguillaum committed
13
open Grew_base
bguillaum's avatar
bguillaum committed
14
open Grew_types
bguillaum's avatar
bguillaum committed
15

16
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
17
module Ast = struct
18

19
  (* general function for checking that an identifier is of the right kind *)
20
  (* allowed is a char list which is a sub set of ['#'; '.'; ':'; '*'] *)
21
22
23
24
25
26
27
28
29
30
31
32
33
34
  let check_special name allowed s =
    let sp = Str.full_split (Str.regexp "#\\|\\.\\|:\\|\\*") s in
    try
      match List.find
      (function
        | Str.Delim d when not (List.mem d allowed) -> true
        | _ -> false
      ) sp
      with
      | Str.Delim wrong_char ->
       Error.build "The identifier '%s' is not a valid %s, the character '%s' is illegal" s name wrong_char
      | Str.Text _ -> Error.bug "[Grew_ast.check_special]"
    with
    | Not_found -> ()
35

36
37
38
39
40
41
  (* ---------------------------------------------------------------------- *)
  (* simple_ident: cat *)
  type simple_ident = Id.name
  let parse_simple_ident s = check_special "simple ident" [] s; s
  let is_simple_ident s = try ignore (parse_simple_ident s); true with _ -> false
  let dump_simple_ident name = name
42

bguillaum's avatar
bguillaum committed
43
  (* ---------------------------------------------------------------------- *)
44
45
46
47
  (* label_ident: D:mod.dis *)
  type label_ident = string
  let parse_label_ident s = check_special "label ident" [":"; "."] s; s
  let dump_label_ident name = name
48

49
50
51
52
53
  (* ---------------------------------------------------------------------- *)
  (* pattern_label_ident: D:mod.* *)
  type pattern_label_ident = string
  let parse_pattern_label_ident s = check_special "label ident" [":"; "."; "*"] s; s
  let dump_pattern_label_ident name = name
54

bguillaum's avatar
bguillaum committed
55
  (* ---------------------------------------------------------------------- *)
56
57
58
59
60
61
62
63
  (* feature_ident: V.cat *)
  type feature_ident = Id.name * feature_name
  let parse_feature_ident s =
    check_special "feature ident" ["."] s;
    match Str.full_split (Str.regexp "\\.") s with
    | [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, fn)
    | _ -> Error.build "The identifier '%s' must be a feature identifier (with exactly one '.' symbol, like \"V.cat\" for instance)" s
  let dump_feature_ident (name, feat_name) = sprintf "%s.%s" name feat_name
64
65


bguillaum's avatar
bguillaum committed
66
  (* ---------------------------------------------------------------------- *)
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
  (* command_node_id: V, V#alpha *)
  type command_node_ident =
    | No_sharp of Id.name
    | Sharp of Id.name * string

  let parse_command_node_ident s =
    check_special "feature ident" ["#"] s;
    match Str.full_split (Str.regexp "#") s with
    | [Str.Text base; Str.Delim "#"; Str.Text ext] -> Sharp (base, ext)
    | [Str.Text base] -> No_sharp base
    | _ -> Error.build "The identifier '%s' must be a command node identifier (with at most one '#' symbol)" s

  let dump_command_node_ident = function
    | No_sharp x -> x
    | Sharp (x,y) -> x ^ "#" ^ y
82
83


84
85
86
  let base_command_node_ident = function
    | No_sharp x -> x
    | Sharp (x,y) -> x
87

bguillaum's avatar
bguillaum committed
88
  (* ---------------------------------------------------------------------- *)
89
90
  (* command_feature_ident: V.cat, V#alpha.cat *)
  type command_feature_ident = command_node_ident * feature_name
91

92
93
94
95
96
97
  let parse_command_feature_ident s =
    check_special "feature ident" ["."; "#"] s;
    match Str.full_split (Str.regexp "#\\|\\.") s with
    | [Str.Text base; Str.Delim "#"; Str.Text ext; Str.Delim "."; Str.Text feature_name] -> (Sharp (base, ext), feature_name)
    | [Str.Text base; Str.Delim "."; Str.Text feature_name] -> (No_sharp base, feature_name)
    | _ -> Error.build "The identifier '%s' must be a command feature identifier (with exactly one '.' symbol and at most one '#' symbol in the left part)" s
98

99
100
101
  let dump_command_feature_ident = function
    | (No_sharp base, feature_name) -> sprintf "%s.%s" base feature_name
    | (Sharp (base,ext), feature_name) -> sprintf "%s#%s.%s" base ext feature_name
102

103
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
104
  type feature_kind =
105
106
    | Equality of feature_value list
    | Disequality of feature_value list
bguillaum's avatar
bguillaum committed
107
    | Equal_param of string (* $ident *)
bguillaum's avatar
bguillaum committed
108
    | Absent
bguillaum's avatar
bguillaum committed
109

bguillaum's avatar
bguillaum committed
110
  type u_feature = {
111
112
113
    name: feature_name;
    kind: feature_kind;
  }
bguillaum's avatar
bguillaum committed
114
  type feature = u_feature * Loc.t
115

bguillaum's avatar
bguillaum committed
116
  type u_node = {
bguillaum's avatar
bguillaum committed
117
118
119
120
    node_id: Id.name;
    position: float option;
    fs: feature list;
  }
bguillaum's avatar
bguillaum committed
121
  type node = u_node * Loc.t
122
123
124

  type edge_label = string

bguillaum's avatar
bguillaum committed
125
126
127
  (* (list of edge_label separated by '|', bool true iff it is a negative constraint) *)
  type edge_label_cst = edge_label list * bool

bguillaum's avatar
bguillaum committed
128
  type u_edge = {
bguillaum's avatar
bguillaum committed
129
130
    edge_id: Id.name option;
    src: Id.name;
bguillaum's avatar
bguillaum committed
131
    edge_label_cst: edge_label_cst;
bguillaum's avatar
bguillaum committed
132
133
    tar: Id.name;
  }
bguillaum's avatar
bguillaum committed
134
  type edge = u_edge * Loc.t
bguillaum's avatar
bguillaum committed
135
136
137
138
139
140
141
142
143

  type ineq = Lt | Gt | Le | Ge

  let string_of_ineq = function
    | Lt -> "<"
    | Gt -> ">"
    | Le -> "≤"
    | Ge -> "≥"

144
  type u_const =
145
146
    | Cst_out of Id.name * edge_label_cst
    | Cst_in of Id.name * edge_label_cst
147
148
149
    | Feature_eq of feature_ident * feature_ident
    | Feature_diseq of feature_ident * feature_ident
    | Feature_ineq of ineq * feature_ident * feature_ident
bguillaum's avatar
bguillaum committed
150
  type const = u_const * Loc.t
151

bguillaum's avatar
bguillaum committed
152
  type basic = {
bguillaum's avatar
bguillaum committed
153
154
155
156
    pat_nodes: node list;
    pat_edges: edge list;
    pat_const: const list;
  }
bguillaum's avatar
bguillaum committed
157

158
159
160
161
162
  type pattern = {
    pat_pos: basic;
    pat_negs: basic list;
  }

163
  type graph = {
bguillaum's avatar
bguillaum committed
164
165
166
    nodes: (Id.name * node) list;
    edge: edge list;
  }
167

bguillaum's avatar
bguillaum committed
168
  type concat_item =
169
    | Qfn_item of feature_ident
bguillaum's avatar
bguillaum committed
170
    | String_item of string
171
    | Param_item of string
bguillaum's avatar
bguillaum committed
172

bguillaum's avatar
bguillaum committed
173
  type u_command =
174
    | Del_edge_expl of (command_node_ident * command_node_ident * edge_label)
bguillaum's avatar
bguillaum committed
175
    | Del_edge_name of string
176
    | Add_edge of (command_node_ident * command_node_ident * edge_label)
177
178

    (* 4 args: source, target, labels, flag true iff negative cst *)
bguillaum's avatar
bguillaum committed
179
180
181
    | Shift_in of (command_node_ident * command_node_ident * edge_label_cst)
    | Shift_out of (command_node_ident * command_node_ident * edge_label_cst)
    | Shift_edge of (command_node_ident * command_node_ident * edge_label_cst)
182

183
184
185
186
187
188
189
    | Merge_node of (command_node_ident * command_node_ident)
    | New_neighbour of (Id.name * command_node_ident * edge_label)
    | Del_node of command_node_ident
    | Activate of command_node_ident

    | Del_feat of command_feature_ident
    | Update_feat of command_feature_ident * concat_item list
bguillaum's avatar
bguillaum committed
190
191
  type command = u_command * Loc.t

192
  (* the [rule] type is used for 3 kinds of module items:
193
194
195
     - rule     { param=None; ... }
     - lex_rule
     - filter   { param=None; commands=[]; ... }
bguillaum's avatar
bguillaum committed
196
  *)
bguillaum's avatar
bguillaum committed
197
  type rule = {
bguillaum's avatar
bguillaum committed
198
    rule_id:Id.name;
bguillaum's avatar
bguillaum committed
199
200
    pos_basic: basic;
    neg_basics: basic list;
bguillaum's avatar
bguillaum committed
201
202
    commands: command list;
    param: (string list * string list) option;
bguillaum's avatar
bguillaum committed
203
    lex_par: string list option;
bguillaum's avatar
bguillaum committed
204
205
206
    rule_doc:string list;
    rule_loc: Loc.t;
  }
207

bguillaum's avatar
bguillaum committed
208
  type modul = {
bguillaum's avatar
bguillaum committed
209
210
    module_id:Id.name;
    local_labels: (string * string list) list;
211
    suffixes: string list;
bguillaum's avatar
bguillaum committed
212
213
214
215
216
217
218
    rules: rule list;
    confluent: bool;
    module_doc:string list;
    mod_loc:Loc.t;
    mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
  }

219
  type old_sequence = {
bguillaum's avatar
bguillaum committed
220
221
222
223
224
225
    seq_name:string;
    seq_mod:string list;
    seq_doc:string list;
    seq_loc:Loc.t;
  }

226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
  type new_sequence =
    | Ref of string
    | List of new_sequence list
    | Plus of new_sequence list
    | Star of new_sequence
    | Diamond of new_sequence

  let rec new_sequence_to_string = function
  | Ref m -> m
  | List l -> "[" ^ (String.concat "; " (List.map new_sequence_to_string l)) ^ "]"
  | Plus l -> "[" ^ (String.concat "+" (List.map new_sequence_to_string l)) ^ "]"
  | Star s -> "[" ^ (new_sequence_to_string s) ^"]"  ^ "*"
  | Diamond s -> "◇" ^ "[" ^(new_sequence_to_string s)^"]"

  let rec flatten = function
  | Ref m -> Ref m
  | Star s -> Star (flatten s)
  | Diamond s -> Diamond (flatten s)
  | List l ->
    let fl = List.map flatten l in
    let rec loop = function
    | [] -> []
    | (List l) :: tail -> l @ (loop tail)
    | x :: tail -> x :: (loop tail)
    in List (loop fl)
  | Plus l ->
    let fl = List.map flatten l in
    let rec loop = function
    | [] -> []
    | (Plus l) :: tail -> l @ (loop tail)
    | x :: tail -> x :: (loop tail)
    in Plus (loop fl)

  type sequence =
  | Old of old_sequence
  | New of ((string * Loc.t) * new_sequence)

bguillaum's avatar
bguillaum committed
263
264
  (** a GRS: graph rewriting system *)
  type module_or_include =
bguillaum's avatar
bguillaum committed
265
    | Modul of modul
266
    | Includ of (string * Loc.t)
bguillaum's avatar
bguillaum committed
267
268

  type grs_with_include = {
bguillaum's avatar
bguillaum committed
269
    domain_wi: Domain.t;
bguillaum's avatar
bguillaum committed
270
271
272
273
    labels_wi: (string * string list) list;    (* the list of global edge labels *)
    modules_wi: module_or_include list;
    sequences_wi: sequence list;
  }
bguillaum's avatar
bguillaum committed
274
275

  type grs = {
bguillaum's avatar
bguillaum committed
276
    domain: Domain.t;
bguillaum's avatar
bguillaum committed
277
278
279
280
    labels: (string * string list) list;
    modules: modul list;
    sequences: sequence list;
  }
bguillaum's avatar
bguillaum committed
281
282

  type gr = {
283
284
285
286
    meta: (string * string) list;
    nodes: node list;
    edges: edge list;
  }
bguillaum's avatar
bguillaum committed
287
288

  let empty_grs = { domain = []; labels = []; modules = []; sequences= [] }
bguillaum's avatar
bguillaum committed
289

290
end (* module Ast *)