Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 55 lines (46 sloc) 1.868 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
19
20 let string_of_production = function
21 | `string s -> `prod (sprintf "(text %s)" s)
22 | `production (hd, tl) -> `prod (sprintf "(print_%s (%s))" hd tl)
23 | `ocaml o -> `prod (sprintf "(%s)" o) (* FIXME: text ? *)
24 | `var v -> `prod v
25 | `operator o -> `change o
26 | `space -> `change "<+>"
27
28 let rec output_productions ?(first=false) ?(operator="<<>>") = function
29 | hd :: tl ->
30 begin
31 match string_of_production hd with
32 | `change operator -> output_productions ~operator tl
33 | `prod p ->
34 if first then p ^ (output_productions tl)
35 else sprintf " %s %s%s" operator p (output_productions tl)
36 end
37 | [] -> ""
38
39 let to_ocaml s =
40 try
41 let _, map = Prxparse.parse_prxparse_file s in
42 let _, code = StringMap.fold (
43 fun name rules (first, acc) ->
44 let init = sprintf "%s %s = function\n" (if first then "let rec" else "and") (sprintf "print_%s" name) in
45 let code = List.fold_left (
46 fun acc (pattern, productions) ->
47 acc ^
48 sprintf "| %s -> %s\n" pattern (if productions=[] then "text \"\"" else output_productions ~first:true productions)
49 ) init rules in
50 false, acc ^ code
51 ) map (true, "") in
52 code
53 with
54 | _ -> Printf.eprintf "Syntax error"; assert false
Something went wrong with that request. Please try again.