Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. 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. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

grew_edge.ml 4.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                                                   *)
(**********************************************************************************)

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

bguillaum's avatar
bguillaum committed
14
open Grew_base
15
open Grew_types
bguillaum's avatar
bguillaum committed
16
open Grew_ast
pj2m's avatar
pj2m committed
17

18 19 20 21 22 23 24 25
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst = struct
  type t =
  | Pos of Label.t list
  | Neg of Label.t list
  | Regexp of (Str.regexp * string)

bguillaum's avatar
bguillaum committed
26 27 28
  let to_string ?domain = function
    | Pos l -> (List_.to_string (Label.to_string ?domain) "|" l)
    | Neg l -> "^"^(List_.to_string (Label.to_string ?domain) "|" l)
29 30 31 32
    | Regexp (_,re) -> "re\""^re^"\""

  let all = Neg []

bguillaum's avatar
bguillaum committed
33
  let match_ ?domain cst g_label = match cst with
34 35
    | Pos labels -> Label.match_list labels g_label
    | Neg labels -> not (Label.match_list labels g_label)
bguillaum's avatar
bguillaum committed
36
    | Regexp (re,_) -> String_.re_match re (Label.to_string ?domain g_label)
37

bguillaum's avatar
bguillaum committed
38 39 40
  let build ?loc ?domain = function
    | Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (Label.from_string ?loc ?domain) p_labels))
    | Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (Label.from_string ?loc ?domain) p_labels))
41 42 43
    | Ast.Regexp re -> Regexp (Str.regexp re, re)
end (* module Label_cst *)

44 45 46 47
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

bguillaum's avatar
bguillaum committed
48
  let to_string ?domain t = Label.to_string ?domain t
49

bguillaum's avatar
bguillaum committed
50
  let make ?loc ?domain string = Label.from_string ?loc ?domain string
51

52 53
  let sub = make "__SUB__"

bguillaum's avatar
bguillaum committed
54
  let build ?domain (ast_edge, loc) =
bguillaum's avatar
bguillaum committed
55
    match ast_edge.Ast.edge_label_cst with
bguillaum's avatar
bguillaum committed
56
    | Ast.Pos_list [one] -> Label.from_string ~loc ?domain one
57 58 59
    | Ast.Neg_list _ -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
    | Ast.Pos_list _ -> Error.build "Only atomic edge values are allowed in graphs%s" (Loc.to_string loc)
    | Ast.Regexp _ -> Error.build "Regexp are not allowed in graphs%s" (Loc.to_string loc)
60

bguillaum's avatar
bguillaum committed
61 62 63
  let is_void ?domain t = Label.is_void ?domain t
  let to_dep ?domain ?(deco=false) t = Label.to_dep ?domain ~deco t
  let to_dot ?domain ?(deco=false) t = Label.to_dot ?domain ~deco t
bguillaum's avatar
bguillaum committed
64

65 66
  let color_of_option = function
    | [] -> None
67
    | c::_ -> Some (String_.rm_first_char c)
bguillaum's avatar
bguillaum committed
68 69
end (* module G_edge *)

70 71
(* ================================================================================ *)
module P_edge = struct
pj2m's avatar
pj2m committed
72
  type t = {
73 74 75
    id: string option; (* an identifier for naming under_label in patterns *)
    label_cst: Label_cst.t;
  }
pj2m's avatar
pj2m committed
76

77
  let all = {id=None; label_cst=Label_cst.all }
bguillaum's avatar
bguillaum committed
78

79
  let get_id t = t.id
pj2m's avatar
pj2m committed
80

bguillaum's avatar
bguillaum committed
81
  let build ?domain (ast_edge, loc) =
pj2m's avatar
pj2m committed
82
    { id = ast_edge.Ast.edge_id;
bguillaum's avatar
bguillaum committed
83
      label_cst = Label_cst.build ~loc ?domain ast_edge.Ast.edge_label_cst
pj2m's avatar
pj2m committed
84 85
    }

bguillaum's avatar
bguillaum committed
86
  let to_string ?domain t =
bguillaum's avatar
bguillaum committed
87
    match t.id with
bguillaum's avatar
bguillaum committed
88 89
    | None -> Label_cst.to_string ?domain t.label_cst
    | Some i -> sprintf "%s:%s" i (Label_cst.to_string ?domain t.label_cst)
pj2m's avatar
pj2m committed
90 91 92 93 94 95

  type edge_matcher =
    | Fail
    | Ok of Label.t
    | Binds of string * Label.t list

bguillaum's avatar
bguillaum committed
96
  let match_ ?domain p_edge g_edge =
97
    match p_edge with
bguillaum's avatar
bguillaum committed
98 99
    | {id = None; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Ok g_edge
    | {id = Some i; label_cst } when Label_cst.match_ ?domain label_cst g_edge -> Binds (i, [g_edge])
100
    | _ -> Fail
pj2m's avatar
pj2m committed
101

bguillaum's avatar
bguillaum committed
102
  let match_list ?domain p_edge g_edge_list =
103
    match p_edge with
bguillaum's avatar
bguillaum committed
104
    | {id = None; label_cst} when List.exists (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list ->
105 106 107
        Ok (List.hd g_edge_list)
    | {id = None} -> Fail
    | {id = Some i; label_cst } ->
bguillaum's avatar
bguillaum committed
108
      ( match List.filter (fun g_edge -> Label_cst.match_ ?domain label_cst g_edge) g_edge_list with
109 110 111
        | [] -> Fail
        | list -> Binds (i, list)
      )
bguillaum's avatar
bguillaum committed
112
end (* module P_edge *)