grew_loader.ml 8.44 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
  let rec loc_new_grs file =
99 100 101 102 103 104 105 106 107
    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

108 109 110
  and unfold_new_grs top new_ast_grs = List.fold_left
    (fun acc decl -> match decl with
      | New_ast.Import filename ->
111 112 113
        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
114 115
        let sub = loc_new_grs filename in
        let unfolded_sub = unfold_new_grs false sub in
116
          New_ast.Package (pack_name, unfolded_sub) :: acc
117 118 119 120 121 122 123 124 125 126 127
      | New_ast.Include filename ->
        let sub = loc_new_grs filename in
        let unfolded_sub = unfold_new_grs top sub in
          unfolded_sub @ acc
      | New_ast.Features _ when not top -> Error.bug "Non top features declaration"
      | New_ast.Labels _ when not top -> Error.bug "Non top labels declaration"
      | x -> x :: acc
    ) [] new_ast_grs

  let new_grs file = unfold_new_grs true (loc_new_grs file)

bguillaum's avatar
bguillaum committed
128
  (* ------------------------------------------------------------------------------------------*)
bguillaum's avatar
bguillaum committed
129
  let gr file =
130
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
131
      Global.new_file file;
132
      let in_ch = open_in file in
bguillaum's avatar
bguillaum committed
133
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
134
      let gr = parse_handle (Grew_parser.gr Grew_lexer.global) lexbuf in
bguillaum's avatar
bguillaum committed
135 136
      close_in in_ch;
      gr
137
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.gr] %s" msg
138

bguillaum's avatar
bguillaum committed
139 140

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

151
  (* ------------------------------------------------------------------------------------------*)
152
  let phrase_structure_tree file =
153
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
154
      Global.new_file file;
155 156
      let in_ch = open_in file in
      let lexbuf = Lexing.from_channel in_ch in
Bruno Guillaume's avatar
Bruno Guillaume committed
157
      let graph = parse_handle (Grew_parser.phrase_structure_tree Grew_lexer.const) lexbuf in
158 159
      close_in in_ch;
      graph
160
    with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.phrase_structure_tree] %s" msg
161

bguillaum's avatar
bguillaum committed
162
end (* module Loader *)
163 164 165 166 167 168


module Parser = struct
  (* ------------------------------------------------------------------------------------------*)
  let gr gr_string =
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
169
      Global.new_string ();
170
      let lexbuf = Lexing.from_string gr_string in
Bruno Guillaume's avatar
Bruno Guillaume committed
171
      let gr = parse_handle (Grew_parser.gr Grew_lexer.global) lexbuf in
172
      gr
173
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.gr] %s" msg
174 175

  (* ------------------------------------------------------------------------------------------*)
176
  let phrase_structure_tree s =
177
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
178
      Global.new_string ();
179
      let lexbuf = Lexing.from_string s in
Bruno Guillaume's avatar
Bruno Guillaume committed
180
      let graph = parse_handle (Grew_parser.phrase_structure_tree Grew_lexer.const) lexbuf in
181
      graph
182 183 184 185 186
    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
187
      Global.new_string ();
188
      let lexbuf = Lexing.from_string desc in
Bruno Guillaume's avatar
Bruno Guillaume committed
189
      let pattern = parse_handle (Grew_parser.pattern Grew_lexer.global) lexbuf in
190 191
      pattern
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.pattern] %s" msg
192

193
  (* ------------------------------------------------------------------------------------------*)
194
  let strat_def desc =
195
    try
Bruno Guillaume's avatar
Bruno Guillaume committed
196
      Global.new_string ();
197
      let lexbuf = Lexing.from_string desc in
Bruno Guillaume's avatar
Bruno Guillaume committed
198
      let strategy = parse_handle (Grew_parser.strat_def Grew_lexer.global) lexbuf in
199 200 201 202
      strategy
    with Sys_error msg -> Error.parse "[Grew_loader.Parser.strategy] %s" msg


203
end