grew_edge.ml 4.17 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
    id: string; (* an identifier for naming under_label in patterns *)
74 75
    label_cst: Label_cst.t;
  }
pj2m's avatar
pj2m committed
76

77 78 79 80
  let cpt = ref 0
  let fresh_name () = incr cpt; sprintf "__e_%d__" !cpt

  let all = {id=fresh_name (); label_cst=Label_cst.all }
bguillaum's avatar
bguillaum committed
81

82
  let get_id t = t.id
pj2m's avatar
pj2m committed
83

bguillaum's avatar
bguillaum committed
84
  let build ?domain (ast_edge, loc) =
85
    { id = (match ast_edge.Ast.edge_id with Some s -> s | None -> fresh_name ());
bguillaum's avatar
bguillaum committed
86
      label_cst = Label_cst.build ~loc ?domain ast_edge.Ast.edge_label_cst
pj2m's avatar
pj2m committed
87 88
    }

bguillaum's avatar
bguillaum committed
89
  let to_string ?domain t =
90 91 92
    if String.length t.id > 1 && t.id.[0] = '_' && t.id.[1] = '_'
    then Label_cst.to_string ?domain t.label_cst
    else sprintf "%s:%s" t.id (Label_cst.to_string ?domain t.label_cst)
pj2m's avatar
pj2m committed
93 94 95 96 97

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

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

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