grew_loader.ml 10.2 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
open Grew_base
bguillaum's avatar
bguillaum committed
12
open Grew_ast
pj2m's avatar
pj2m committed
13

14 15
(* ------------------------------------------------------------------------------------------*)
(** general function to handle parse errors *)
Bruno Guillaume's avatar
Bruno Guillaume committed
16
let parse_handle fct lexbuf =
17
  try fct lexbuf with
Bruno Guillaume's avatar
Bruno Guillaume committed
18 19 20
    | Grew_lexer.Error msg -> Error.parse ~loc:(Global.get_loc ()) "Lexing error: %s" msg
    | Grew_parser.Error -> Error.parse ~loc:(Global.get_loc ()) "Syntax error: %s" (Lexing.lexeme lexbuf)
    | Error.Build (msg, None) -> Error.parse ~loc:(Global.get_loc ()) "Syntax error: %s" msg
bguillaum's avatar
bguillaum committed
21
    | Error.Build (msg, Some loc) -> Error.parse ~loc "Syntax error: %s" msg
Bruno Guillaume's avatar
Bruno Guillaume committed
22 23
    | Failure msg -> Error.parse ~loc:(Global.get_loc ()) "Failure: %s" msg
    | err -> Error.bug ~loc:(Global.get_loc ()) "Unexpected error: %s" (Printexc.to_string err)
pj2m's avatar
pj2m committed
24

25
module Loader = struct
bguillaum's avatar
bguillaum committed
26

bguillaum's avatar
bguillaum committed
27 28

  (* ------------------------------------------------------------------------------------------*)
29
  let parse_file_to_grs_wi file =
30
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
31
      Global.new_file file;
32
      let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
33
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
34
      let grs = parse_handle (Grew_parser.grs_wi Grew_lexer.global) lexbuf in
bguillaum's avatar
bguillaum committed
35 36
      close_in in_ch;
      grs
37
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.parse_file_to_grs_wi] %s" msg
pj2m's avatar
pj2m committed
38

bguillaum's avatar
bguillaum committed
39
  (* ------------------------------------------------------------------------------------------*)
40
  let parse_file_to_module_list file =
41
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
42
      Global.new_file file;
43
      let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
44
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
45
      let module_list = parse_handle (Grew_parser.included Grew_lexer.global) lexbuf in
bguillaum's avatar
bguillaum committed
46 47
      close_in in_ch;
      module_list
48
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.parse_file_to_module_list] %s" msg
pj2m's avatar
pj2m committed
49

50 51 52
  (* ------------------------------------------------------------------------------------------*)
  let domain file =
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
53
      Global.new_file file;
54 55
      let in_ch = open_in file in
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
56
      let gr = parse_handle (Grew_parser.domain Grew_lexer.global) lexbuf in
57 58
      close_in in_ch;
      gr
59
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.domain] %s" msg
60

bguillaum's avatar
bguillaum committed
61
  (* ------------------------------------------------------------------------------------------*)
62 63 64 65
  (**
     [parse_string file] where [file] is a file following the grew syntax
     @param file the file to parse
     @return a syntactic tree of the parsed file
bguillaum's avatar
bguillaum committed
66
  *)
bguillaum's avatar
bguillaum committed
67
  let grs main_file =
bguillaum's avatar
bguillaum committed
68 69 70 71 72 73 74 75
    let real_dir =
      match (Unix.lstat main_file).Unix.st_kind with
      | Unix.S_LNK -> Filename.dirname (Unix.readlink main_file)
      | _ -> Filename.dirname main_file in

    let unlink file = Filename.concat real_dir (Filename.basename file) in

    let grs_wi = parse_file_to_grs_wi (unlink main_file) in
76
    let domain = match grs_wi.Ast.domain_wi with
bguillaum's avatar
bguillaum committed
77 78
      | None -> None
      | Some (Ast.Dom d) -> Some d
bguillaum's avatar
bguillaum committed
79
      | Some (Ast.Dom_file file) -> Some (domain (unlink file)) in
80
    let rec flatten_modules current_file = function
81
      | [] -> []
bguillaum's avatar
bguillaum committed
82 83 84 85 86 87 88 89
      | Ast.Modul m :: tail ->
        {m with Ast.mod_dir = Filename.dirname current_file}
        :: (flatten_modules current_file tail)
      | Ast.Includ (inc_file,loc) :: tail ->
        let sub_file =
          if Filename.is_relative inc_file
          then Filename.concat (Filename.dirname current_file) inc_file
          else inc_file in
90
        (flatten_modules sub_file (parse_file_to_module_list sub_file))
bguillaum's avatar
bguillaum committed
91
        @ (flatten_modules current_file tail) in
92
    {
93 94
      Ast.domain = domain;
      Ast.modules = flatten_modules main_file grs_wi.Ast.modules_wi;
bguillaum's avatar
bguillaum committed
95
      Ast.strategies = grs_wi.Ast.strategies_wi;
bguillaum's avatar
bguillaum committed
96
    }
bguillaum's avatar
bguillaum committed
97

98 99 100 101 102 103 104 105








106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
  let rec check_duplicate_id id = function
    | [] -> None
    | New_ast.Rule r :: _ when r.Ast.rule_id = id -> Some r.Ast.rule_loc
    | New_ast.Package (loc, name, _) :: _ when name = id -> Some loc
    | New_ast.Strategy (loc, name, _) :: _ when name = id -> Some loc
    | _ -> None

  let rec check_grs = function
    | [] -> ()
    | New_ast.Rule r :: tail ->
      begin
        match check_duplicate_id r.Ast.rule_id tail with
        | None -> ()
        | Some loc -> Error.build "Identifier \"%s\" is used twice in the same package (%s and %s)"
          r.Ast.rule_id (Loc.to_string r.Ast.rule_loc) (Loc.to_string loc)
      end;
      check_grs tail
    | New_ast.Strategy (loc, name, _) :: tail
    | New_ast.Package (loc, name, _) :: tail ->
      begin
        match check_duplicate_id name tail with
        | None -> ()
        | Some loc2 -> Error.build "Identifier \"%s\" is used twice in the same package (%s and %s)"
          name (Loc.to_string loc) (Loc.to_string loc2)
      end;
      check_grs tail
    | _ :: tail -> check_grs tail

134 135 136 137 138 139 140 141
  let real_dir file =
    match (Unix.lstat file).Unix.st_kind with
    | Unix.S_LNK -> Filename.dirname (Unix.readlink file)
    | _ -> Filename.dirname file

  let unlink dir file = Filename.concat dir (Filename.basename file)

  let loc_new_grs file =
142 143 144 145 146 147 148 149 150
    try
      Global.new_file file;
      let in_ch = open_in file in
      let lexbuf = Lexing.from_channel in_ch in
      let grs = parse_handle (Grew_parser.new_grs Grew_lexer.global) lexbuf in
      close_in in_ch;
      grs
  with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.grs] %s" msg

151 152
  let rec unfold_new_grs dir top new_ast_grs =
  List.fold_left
153 154
    (fun acc decl -> match decl with
      | New_ast.Import filename ->
155
        let real_file = unlink dir filename in
156 157 158
        let pack_name = match CCString.chop_suffix ~suf:".grs" filename with
          | Some x -> x
          | None -> Error.build "Imported file must have the \".grs\" file extension" in
159
        let sub = loc_new_grs filename in
160
        let unfolded_sub = unfold_new_grs (real_dir real_file) false sub in
161
          New_ast.Package (Loc.file filename, pack_name, unfolded_sub) :: acc
162
      | New_ast.Include filename ->
163 164 165
        let real_file = unlink dir filename in
        let sub = loc_new_grs real_file in
        let unfolded_sub = unfold_new_grs (real_dir real_file) top sub in
166
          unfolded_sub @ acc
167 168
      | New_ast.Features _ when not top -> Error.build "Non top features declaration"
      | New_ast.Labels _ when not top -> Error.build "Non top labels declaration"
169 170 171 172
      | New_ast.Package (loc, name, decls) ->
        New_ast.Package (loc, name, unfold_new_grs dir top decls) :: acc
      | New_ast.Rule ast_rule ->
        New_ast.Rule {ast_rule with Ast.rule_dir = Some dir} :: acc
173 174 175
      | x -> x :: acc
    ) [] new_ast_grs

176
  let new_grs file =
177
    let final_grs = unfold_new_grs (real_dir file) true (loc_new_grs file) in
178 179
    check_grs final_grs;
    final_grs
180

bguillaum's avatar
bguillaum committed
181
  (* ------------------------------------------------------------------------------------------*)
bguillaum's avatar
bguillaum committed
182
  let gr file =
183
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
184
      Global.new_file file;
185
      let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
186
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
187
      let gr = parse_handle (Grew_parser.gr Grew_lexer.global) lexbuf in
bguillaum's avatar
bguillaum committed
188 189
      close_in in_ch;
      gr
190
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.gr] %s" msg
191

bguillaum's avatar
bguillaum committed
192 193

  (* ------------------------------------------------------------------------------------------*)
bguillaum's avatar
bguillaum committed
194
  let pattern file =
bguillaum's avatar
bguillaum committed
195
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
196
      Global.new_file file;
bguillaum's avatar
bguillaum committed
197 198
      let in_ch = open_in file in
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
199
      let pattern = parse_handle (Grew_parser.pattern Grew_lexer.global) lexbuf in
bguillaum's avatar
bguillaum committed
200
      close_in in_ch;
201 202
      pattern
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.pattern] %s" msg
bguillaum's avatar
bguillaum committed
203

204
  (* ------------------------------------------------------------------------------------------*)
205
  let phrase_structure_tree file =
206
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
207
      Global.new_file file;
208 209
      let in_ch = open_in file in
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
210
      let graph = parse_handle (Grew_parser.phrase_structure_tree Grew_lexer.const) lexbuf in
211 212
      close_in in_ch;
      graph
213
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.phrase_structure_tree] %s" msg
214

bguillaum's avatar
bguillaum committed
215
end (* module Loader *)
216 217 218 219 220 221


module Parser = struct
  (* ------------------------------------------------------------------------------------------*)
  let gr gr_string =
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
222
      Global.new_string ();
223
      let lexbuf = Lexing.from_string gr_string in
Bruno Guillaume's avatar
Bruno Guillaume committed
224
      let gr = parse_handle (Grew_parser.gr Grew_lexer.global) lexbuf in
225
      gr
226
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.gr] %s" msg
227 228

  (* ------------------------------------------------------------------------------------------*)
229
  let phrase_structure_tree s =
230
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
231
      Global.new_string ();
232
      let lexbuf = Lexing.from_string s in
Bruno Guillaume's avatar
Bruno Guillaume committed
233
      let graph = parse_handle (Grew_parser.phrase_structure_tree Grew_lexer.const) lexbuf in
234
      graph
235 236 237 238 239
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.phrase_structure_tree] %s" msg

  (* ------------------------------------------------------------------------------------------*)
  let pattern desc =
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
240
      Global.new_string ();
241
      let lexbuf = Lexing.from_string desc in
Bruno Guillaume's avatar
Bruno Guillaume committed
242
      let pattern = parse_handle (Grew_parser.pattern Grew_lexer.global) lexbuf in
243 244
      pattern
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.pattern] %s" msg
245

246 247 248 249 250 251 252 253 254
  (* ------------------------------------------------------------------------------------------*)
  let strategy desc =
    try
      Global.new_string ();
      let lexbuf = Lexing.from_string desc in
      let strategy = parse_handle (Grew_parser.strat_desc Grew_lexer.global) lexbuf in
      strategy
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.strategy] %s" msg

255

256
end