grew_loader.ml 10.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
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
  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

126 127 128 129 130 131 132 133
  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 =
134 135 136 137 138 139 140 141 142
    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

143
  let rec unfold_new_grs dir top new_ast_grs = List.fold_left
144 145
    (fun acc decl -> match decl with
      | New_ast.Import filename ->
146
        let real_file = unlink dir filename in
147 148 149
        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
150
        let sub = loc_new_grs filename in
151
        let unfolded_sub = unfold_new_grs (real_dir real_file) false sub in
152
          New_ast.Package (Loc.file filename, pack_name, unfolded_sub) :: acc
153
      | New_ast.Include filename ->
154 155 156
        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
157
          unfolded_sub @ acc
158 159
      | New_ast.Features _ when not top -> Error.build "Non top features declaration"
      | New_ast.Labels _ when not top -> Error.build "Non top labels declaration"
160 161 162
      | x -> x :: acc
    ) [] new_ast_grs

163
  let new_grs file =
164
    let final_grs = unfold_new_grs (real_dir file) true (loc_new_grs file) in
165 166
    check_grs final_grs;
    final_grs
167

bguillaum's avatar
bguillaum committed
168
  (* ------------------------------------------------------------------------------------------*)
bguillaum's avatar
bguillaum committed
169
  let gr file =
170
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
171
      Global.new_file file;
172
      let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
173
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
174
      let gr = parse_handle (Grew_parser.gr Grew_lexer.global) lexbuf in
bguillaum's avatar
bguillaum committed
175 176
      close_in in_ch;
      gr
177
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.gr] %s" msg
178

bguillaum's avatar
bguillaum committed
179 180

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

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

bguillaum's avatar
bguillaum committed
202
end (* module Loader *)
203 204 205 206 207 208


module Parser = struct
  (* ------------------------------------------------------------------------------------------*)
  let gr gr_string =
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
209
      Global.new_string ();
210
      let lexbuf = Lexing.from_string gr_string in
Bruno Guillaume's avatar
Bruno Guillaume committed
211
      let gr = parse_handle (Grew_parser.gr Grew_lexer.global) lexbuf in
212
      gr
213
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.gr] %s" msg
214 215

  (* ------------------------------------------------------------------------------------------*)
216
  let phrase_structure_tree s =
217
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
218
      Global.new_string ();
219
      let lexbuf = Lexing.from_string s in
Bruno Guillaume's avatar
Bruno Guillaume committed
220
      let graph = parse_handle (Grew_parser.phrase_structure_tree Grew_lexer.const) lexbuf in
221
      graph
222 223 224 225 226
    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
227
      Global.new_string ();
228
      let lexbuf = Lexing.from_string desc in
Bruno Guillaume's avatar
Bruno Guillaume committed
229
      let pattern = parse_handle (Grew_parser.pattern Grew_lexer.global) lexbuf in
230 231
      pattern
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.pattern] %s" msg
232

233
  (* ------------------------------------------------------------------------------------------*)
234
  let strat_def desc =
235
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
236
      Global.new_string ();
237
      let lexbuf = Lexing.from_string desc in
Bruno Guillaume's avatar
Bruno Guillaume committed
238
      let strategy = parse_handle (Grew_parser.strat_def Grew_lexer.global) lexbuf in
239 240 241
      strategy
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.strategy] %s" msg

242 243 244 245 246 247 248 249 250
  (* ------------------------------------------------------------------------------------------*)
  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

251

252
end