Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 234 lines (207 sloc) 9.148 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19 module String = BaseString
20
21 (* type alias *)
22 type filename = string
23 type contents = string
24 type nonuid = SurfaceAst.nonuid
25
26 (* meta-information *)
27 let hash = OpaParserVersion.hash
28
29 (* low level parsing *)
30 let ll_factory parser_rule ?filename contents =
31 let _filename = filename in
32 let _start = None in
33 let _pos, result = parser_rule ?_filename ?_start contents in
34 result
35
36 let ll_expr = ll_factory Opa_parser.parse_opa_parser_expr_eoi
37 let ll_ty = ll_factory Opa_parser.parse_opa_parser_ty_eoi
38 let ll_code = ll_factory Opa_parser.parse_opa_parser_main_eoi
39
40 (* ====================================================================================== *)
41 (* TODO: clean-up *)
42 exception Specific_parse_error = Parser_utils.Specific_parse_error
43 let parse_file_content ~filename content =
44 let _pos, code = Opa_parser.parse_opa_parser_main_eoi ~_filename:filename content in
45 code
46
47 exception No_such_file of string
48 let parse_file filename =
49 match File.content_opt filename with
50 | None -> raise (No_such_file filename)
51 | Some content -> parse_file_content ~filename content
52
53 let parse_content_expr ~filename content =
54 let _pos, code = Opa_parser.parse_opa_parser_expr_eoi ~_filename:filename content in
55 code
56 (* ====================================================================================== *)
57
58 module CacheParse =
59 struct
60 open Digest
61 open Unix
62
63 let caching_directory = Lazy.lazy_from_val (
64 Filename.concat (Lazy.force File.mlstate_dir) "opa/cache/parser"
65 )
66 let check_directory () =
67 if Sys.file_exists (Lazy.force caching_directory) then ()
68 else (
69 #<If:TESTING>
70 ()
71 #<Else>
72 OManager.verbose "opa-parser: creating @{<bright>%s@} to store opa compiler caches" (Lazy.force caching_directory)
73 #<End>;
74 if not (File.check_create_path (Lazy.force caching_directory))
75 then
76 OManager.error (
77 "cannot create cache directory @{<bright>%s@}^@\n"^^
78 "@{<bright>Hint@}:@\n"^^
79 "You can try to create manually the directory, with permissions 755"
80 )
81 (Lazy.force caching_directory)
82 )
83
84 (* cache file naming option *)
85 (* setting true everywhere minimize disk consumption *)
86 (* cannot set the 3 to true !!!*)
87 (* see filename *)
88 let k_last_version = true (* only last compiler version *) (* for faster debugging *)
89 let k_last_hash = true (* only last file content *) (* not proof to undo redo *)
90 let k_last_name = false (* only last file name *) (* not proof to name changing,multiple file with same name *)
91
92 let _ = assert( (not k_last_name) || (not k_last_hash))
93
94 let verify_last_version = true
95
96 let keep_only last value =
97 if (*keep_only*)last(*value*) then "last" else value
98
99 (* name is form of [hash| "last"] concatenation for name hash version
100 that is why having "last" everywhere is bad
101 *)
102 let filename name hash =
103 let name = String.replace name "/" ":" in
104 Printf.sprintf "%s/%s-%s-opaparse.%s.bin"
105 (Lazy.force caching_directory)
106 (keep_only k_last_name name)
107 (keep_only k_last_hash hash)
108 (Unix.gethostname ())
109
110 let set name content result =
111 let internal_version = OpaParserVersion.hash in
112 let _ = check_directory () in
113 let hash = to_hex (Digest.string content) in
114 let filename = filename name hash in
115 match (try Some (open_out_bin filename)
116 with Sys_error _msg ->
117 #<If:PARSER_CACHE_DEBUG>OManager.printf "Failed to write in %s: %s@." filename _msg#<End>;
118 None
119 ) with
120 | None -> ()
121 | Some c ->
122 Marshal.to_channel c (name,hash,internal_version,(result: (string,'b) SurfaceAst.code)) [];
123 close_out c
124
125 let get name content =
126 let internal_version = OpaParserVersion.hash in
127 let _ = check_directory () in
128 let hash = to_hex (Digest.string content) in
129 let cache_file = filename name hash in
130 if Sys.file_exists cache_file then (
131 match (try Some (open_in_bin cache_file) with Sys_error _ -> None) with
132 | None -> None
133 | Some c ->
134 let (_oldname,oldhash,oldversion,res) =
135 try (Marshal.from_channel c : string * string * string * (string,'b) SurfaceAst.code)
136 with End_of_file -> OManager.printf "Bad cache@\n" ; "","","",[]
137 in
138 close_in c;
139 if oldhash=hash && ((not verify_last_version) || oldversion=internal_version) then (Some res)
140 else None
141 ) else None
142 end
143
144 let rec get_index_N_lines_before s i nl =
145 if nl=0 then i else
146 let i' = try String.rindex_from s i '\n' with Not_found -> 0 in
147 if i' = 0 then 0 else get_index_N_lines_before s (i'-1) (nl-1)
148
149 let get_index_N_lines_after s i nl =
150 let len = String.length s - 1 in
151 let rec get i nl =
152 if nl=0 then i else
153 let i' = try String.index_from s i '\n' with Not_found -> len in
154 if i' = len then len else get (i'+1) (nl-1)
155 in get i nl
156
157 (* FIXME, use FilePos for obtaining citations etc. *)
158 let show_parse_error file_name content error_summary error_details pos =
159 let n = max 0 (min pos (String.length content-1)) in
160 let begin_citation = get_index_N_lines_before content n 5 in
161 let length_citation = n - begin_citation in
162 let begin_error_zone = get_index_N_lines_before content n 0 in
163 let length_error_zone = min( (get_index_N_lines_after content n 5)-begin_error_zone +1) (String.length content -begin_error_zone) in
164 let red = Ansi.print `red
165 and green = Ansi.print `green in
166 let line, col, gchar =
167 if pos = -1 then
168 "??", "??", "??"
169 else
170 let line_int, col_int = FilePos.get_pos file_name pos in
171 string_of_int line_int, string_of_int col_int, string_of_int pos
172 in
173 (* FIXME: use really format *)
174 OManager.printf "%s" (
175 (Printf.sprintf "In %s [%s:%s-%s:%s | global chars=%s-%s]\n%s at line %s, column %s\n"
176 (red file_name) line col line col gchar gchar
177 (red error_summary) (red line) (red col)
178 )
179 ^ (Printf.sprintf "The error may be in the following citation, usually in the %s part (starting at ⚐) or just before:" (red"red"))
180 ^ (Printf.sprintf "\n<<%s%s>>\n"
181 (green (String.sub content begin_citation length_citation ))
182 (red (""^(String.sub content begin_error_zone length_error_zone))))
183 ^ (Printf.sprintf "Hint: %s\n" error_details)
184 ) ;
185 OManager.error "Syntax error"
186 (* ====================================================================================== *)
187
188 (* high level parsing *)
189 let hl_factory parser_rule name ?filename contents =
190 try
191 ll_factory parser_rule ?filename contents
192 with
193 | Trx_runtime.SyntaxError (loc, err) ->
194 let filename = Option.default name filename in
195 show_parse_error filename contents "Syntax error" err loc
196
197 let expr = hl_factory Opa_parser.parse_opa_parser_expr_eoi "Expression"
198 let ty = hl_factory Opa_parser.parse_opa_parser_ty_eoi "Type"
199
200 let code ?(cache=false) ?(filename="") content =
201 (*print_string content;*)
202 FilePos.add_file filename content;
203 match if cache then CacheParse.get filename content else None with
204 | None ->
205 #<If:PARSER_CACHE_DEBUG>OManager.printf "Cache @{<red>miss@} for %s@." filename#<End>;
206 let res =
207 try
208 Chrono.measure (fun () -> parse_file_content ~filename content)
209 (fun f ->
210 #<If:TESTING>
211 ()
212 #<Else>
213 if f > 1.0 && (not BuildInfos.is_release) then
214 Printf.printf
215 "Parsing of %s is too long : %1.3f seconds \n%!"
216 filename f
217 #<End>)
218 with
219 | Trx_runtime.SyntaxError (pos, err) ->
220 show_parse_error filename content "Syntax error" err pos
221 | Specific_parse_error (pos, err) ->
222 show_parse_error filename content "Error" err (FilePos.get_first_char pos) (* FIXME, whole range should be used *)
223 | err ->
224 (* All parser error in OPA should use the [Specific_parse_error] exception.
225 Otherwise we have no location to report... *)
226 show_parse_error filename content "Error" (Printexc.to_string err) (-1)
227 in
228 OManager.flush_errors (); (* make sure that if someone threw errors, then we stop before saving the cache *)
229 if cache then CacheParse.set filename content res;
230 res
231 | Some l ->
232 #<If:PARSER_CACHE_DEBUG>OManager.printf "Cache @{<green>hit@} for %s@." filename#<End>;
233 l
Something went wrong with that request. Please try again.