grew_edge.ml 4.43 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 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
(* ================================================================================ *)
(** 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)

  let to_string label_domain = function
    | Pos l -> (List_.to_string (Label.to_string label_domain) "|" l)
    | Neg l -> "^"^(List_.to_string (Label.to_string label_domain) "|" l)
    | Regexp (_,re) -> "re\""^re^"\""

  let all = Neg []

  let match_ label_domain cst g_label = match cst with
    | Pos labels -> Label.match_list labels g_label
    | Neg labels -> not (Label.match_list labels g_label)
    | Regexp (re,_) -> String_.re_match re (Label.to_string label_domain g_label)

  let build ?loc label_domain = function
    | Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (Label.from_string ?loc label_domain) p_labels))
    | Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (Label.from_string ?loc label_domain) p_labels))
    | Ast.Regexp re -> Regexp (Str.regexp re, re)
end (* module Label_cst *)

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

48
  let to_string label_domain t = Label.to_string label_domain t
49

50
  let make ?loc label_domain string = Label.from_string ?loc label_domain string
51

52
  let build label_domain (ast_edge, loc) =
bguillaum's avatar
bguillaum committed
53
    match ast_edge.Ast.edge_label_cst with
54 55 56 57
    | Ast.Pos_list [one] -> Label.from_string ~loc label_domain one
    | 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)
58

59
  let is_void label_domain t = Label.is_void label_domain t
60 61
  let to_dep label_domain ?(deco=false) t = Label.to_dep label_domain ~deco t
  let to_dot label_domain ?(deco=false) t = Label.to_dot label_domain ~deco t
bguillaum's avatar
bguillaum committed
62

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

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

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

77
  let get_id t = t.id
pj2m's avatar
pj2m committed
78

79
  let build label_domain (ast_edge, loc) =
pj2m's avatar
pj2m committed
80
    { id = ast_edge.Ast.edge_id;
81
      label_cst = Label_cst.build ~loc label_domain ast_edge.Ast.edge_label_cst
pj2m's avatar
pj2m committed
82 83
    }

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

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

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

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