MAJ terminée. Nous sommes passés en version 14.6.2 . Pour consulter les "releases notes" associées c'est ici :

https://about.gitlab.com/releases/2022/01/11/security-release-gitlab-14-6-2-released/
https://about.gitlab.com/releases/2022/01/04/gitlab-14-6-1-released/

grew_ast.ml 11.3 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
  (* feature_ident: V.cat *)
  type feature_ident = Id.name * feature_name
58
59
  let dump_feature_ident (name, feat_name) = sprintf "%s.%s" name feat_name

60
61
62
63
64
  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
65

66
67
68
69
70
71
  let parse_ineq_ident s =
    check_special "feature ident" ["."] s;
    match Str.full_split (Str.regexp "\\.") s with
    | [Str.Text base; ] -> (base, "position")
    | [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
72

bguillaum's avatar
bguillaum committed
73
  (* ---------------------------------------------------------------------- *)
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
  (* 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
89
90


91
92
93
  let base_command_node_ident = function
    | No_sharp x -> x
    | Sharp (x,y) -> x
94

bguillaum's avatar
bguillaum committed
95
  (* ---------------------------------------------------------------------- *)
96
97
  (* command_feature_ident: V.cat, V#alpha.cat *)
  type command_feature_ident = command_node_ident * feature_name
98

99
100
101
102
103
104
  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
105

106
107
108
  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
109

110
  (* ---------------------------------------------------------------------- *)
bguillaum's avatar
bguillaum committed
111
  type feature_kind =
112
113
    | Equality of feature_value list
    | Disequality of feature_value list
bguillaum's avatar
bguillaum committed
114
    | Equal_param of string (* $ident *)
bguillaum's avatar
bguillaum committed
115
    | Absent
bguillaum's avatar
bguillaum committed
116

bguillaum's avatar
bguillaum committed
117
  type u_feature = {
118
119
120
    name: feature_name;
    kind: feature_kind;
  }
bguillaum's avatar
bguillaum committed
121
  type feature = u_feature * Loc.t
122

bguillaum's avatar
bguillaum committed
123
  type u_node = {
bguillaum's avatar
bguillaum committed
124
125
126
127
    node_id: Id.name;
    position: float option;
    fs: feature list;
  }
bguillaum's avatar
bguillaum committed
128
  type node = u_node * Loc.t
129
130
131

  type edge_label = string

bguillaum's avatar
bguillaum committed
132
133
134
  (* (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
135
  type u_edge = {
bguillaum's avatar
bguillaum committed
136
137
    edge_id: Id.name option;
    src: Id.name;
bguillaum's avatar
bguillaum committed
138
    edge_label_cst: edge_label_cst;
bguillaum's avatar
bguillaum committed
139
140
    tar: Id.name;
  }
bguillaum's avatar
bguillaum committed
141
  type edge = u_edge * Loc.t
bguillaum's avatar
bguillaum committed
142
143
144
145
146
147
148
149
150

  type ineq = Lt | Gt | Le | Ge

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

151
  type u_const =
152
153
    | Cst_out of Id.name * edge_label_cst
    | Cst_in of Id.name * edge_label_cst
154
155
156
    | Feature_eq of feature_ident * feature_ident
    | Feature_diseq of feature_ident * feature_ident
    | Feature_ineq of ineq * feature_ident * feature_ident
157
    | Feature_ineq_cst of ineq * feature_ident * float
bguillaum's avatar
bguillaum committed
158
    | Feature_re of feature_ident * string
bguillaum's avatar
bguillaum committed
159
  type const = u_const * Loc.t
160

bguillaum's avatar
bguillaum committed
161
  type basic = {
bguillaum's avatar
bguillaum committed
162
163
164
165
    pat_nodes: node list;
    pat_edges: edge list;
    pat_const: const list;
  }
bguillaum's avatar
bguillaum committed
166

167
168
169
170
171
  type pattern = {
    pat_pos: basic;
    pat_negs: basic list;
  }

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
  let add_implicit_node loc aux name pat_nodes =
    if (List.exists (fun ({node_id},_) -> node_id=name) pat_nodes)
    || (List.exists (fun ({node_id},_) -> node_id=name) aux)
    then pat_nodes
    else ({node_id=name; position=None; fs=[]}, loc) :: pat_nodes

  let complete_basic aux {pat_nodes; pat_edges; pat_const} =
    let pat_nodes_2 = List.fold_left
    (fun acc ({src; tar}, loc) ->
      acc
      |> (add_implicit_node loc aux src)
      |> (add_implicit_node loc aux tar)
    ) pat_nodes pat_edges in

    let pat_nodes_3 = List.fold_left
    (fun acc (u_const, loc) -> match u_const with
      | Feature_eq ((name1,_), (name2,_))
      | Feature_diseq ((name1,_), (name2,_))
      | Feature_ineq (_, (name1,_), (name2,_)) ->
        acc
        |> (add_implicit_node loc aux name1)
        |> (add_implicit_node loc aux name2)
194
195
196
197
      | Feature_ineq_cst (_, (name,_), _)
      | Feature_re ((name,_), _) ->
        acc
        |> (add_implicit_node loc aux name)
198
199
200
201
202
203
204
205
206
207
208
      | _ -> acc
    ) pat_nodes_2 pat_const in

    {pat_nodes=pat_nodes_3; pat_edges; pat_const}

  let complete_pattern pattern =
    let new_pat_pos = complete_basic [] pattern.pat_pos in
    let aux = new_pat_pos.pat_nodes in
    let new_pat_negs = List.map (complete_basic aux) pattern.pat_negs in
    { pat_pos = new_pat_pos; pat_negs = new_pat_negs;}

209
  type graph = {
bguillaum's avatar
bguillaum committed
210
211
212
    nodes: (Id.name * node) list;
    edge: edge list;
  }
213

bguillaum's avatar
bguillaum committed
214
  type concat_item =
215
    | Qfn_item of feature_ident
bguillaum's avatar
bguillaum committed
216
    | String_item of string
217
    | Param_item of string
bguillaum's avatar
bguillaum committed
218

bguillaum's avatar
bguillaum committed
219
  type u_command =
220
    | Del_edge_expl of (command_node_ident * command_node_ident * edge_label)
bguillaum's avatar
bguillaum committed
221
    | Del_edge_name of string
222
    | Add_edge of (command_node_ident * command_node_ident * edge_label)
223
224

    (* 4 args: source, target, labels, flag true iff negative cst *)
bguillaum's avatar
bguillaum committed
225
226
227
    | 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)
228

229
230
231
232
233
234
235
    | 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
236
237
  type command = u_command * Loc.t

238
  (* the [rule] type is used for 3 kinds of module items:
239
240
241
     - rule     { param=None; ... }
     - lex_rule
     - filter   { param=None; commands=[]; ... }
bguillaum's avatar
bguillaum committed
242
  *)
bguillaum's avatar
bguillaum committed
243
  type rule = {
bguillaum's avatar
bguillaum committed
244
    rule_id:Id.name;
245
    pattern: pattern;
bguillaum's avatar
bguillaum committed
246
    commands: command list;
247
248
    param: (string list * string list) option; (* (files, vars) *)
    lex_par: string list option; (* lexical parameters in the file *)
bguillaum's avatar
bguillaum committed
249
250
251
    rule_doc:string list;
    rule_loc: Loc.t;
  }
252

bguillaum's avatar
bguillaum committed
253
  type modul = {
bguillaum's avatar
bguillaum committed
254
255
    module_id:Id.name;
    local_labels: (string * string list) list;
256
    suffixes: string list;
bguillaum's avatar
bguillaum committed
257
258
259
260
261
262
263
    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) *)
  }

264
  type old_sequence = {
bguillaum's avatar
bguillaum committed
265
266
267
268
269
270
    seq_name:string;
    seq_mod:string list;
    seq_doc:string list;
    seq_loc:Loc.t;
  }

271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
  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
308
309
  (** a GRS: graph rewriting system *)
  type module_or_include =
bguillaum's avatar
bguillaum committed
310
    | Modul of modul
311
    | Includ of (string * Loc.t)
bguillaum's avatar
bguillaum committed
312

313
314
315
316
317
318
319
  type domain = {
      feature_domain: Feature_domain.feature_spec list;
      label_domain: (string * string list) list;
    }

  let empty_domain = { feature_domain=[]; label_domain=[] }

bguillaum's avatar
bguillaum committed
320
  type grs_with_include = {
321
    domain_wi: domain;
bguillaum's avatar
bguillaum committed
322
323
324
    modules_wi: module_or_include list;
    sequences_wi: sequence list;
  }
bguillaum's avatar
bguillaum committed
325
326

  type grs = {
327
    domain: domain;
bguillaum's avatar
bguillaum committed
328
329
330
    modules: modul list;
    sequences: sequence list;
  }
bguillaum's avatar
bguillaum committed
331
332

  type gr = {
333
334
335
336
    meta: (string * string) list;
    nodes: node list;
    edges: edge list;
  }
bguillaum's avatar
bguillaum committed
337

338
  let empty_grs = { domain = empty_domain; modules = []; sequences= [] }
bguillaum's avatar
bguillaum committed
339

340
end (* module Ast *)