Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 205 lines (161 sloc) 5.804 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 @author Adam Koprowski
20 **)
21
22 (**
23 * A tool for converting TRX grammar to Coq format acceptable by certified TRX
24 **)
25
26 module T = Tgrammar
27 module P = T.PreGrammar
28
29 let module_prefix = ref ""
30
31 let prodName s =
32 if String.is_prefix !module_prefix s then
33 let at = String.length !module_prefix + 1 in
34 "P_" ^ String.sub s at (String.length s - at)
35 else
36 s
37
38 let prod2str s = Printf.sprintf "%s => \"%s\"" (prodName s) (prodName s)
39
40 let header () = Printf.sprintf "
41 (** -- begin LICENCE
42 (c) 2006-2009 MLstate
43 All rights reserved.
44 This file is confidential and intended solely for the addressee(s).
45 Any unauthorized use or dissemination is prohibited.
46 end LICENCE --
47 **)
48
49 (*
50 * WARNING! Grammar generated automatically by %s from %s
51 * =============== Edit at your own risk ==================
52 *)
53 Require Import MLstate.TRX.TRX.
54
55 Set Implicit Arguments.
56 " Sys.argv.(0) Sys.argv.(1)
57
58 let domain peg =
59 let prods = StringMap.keys peg.T.grammar in
60 Printf.sprintf "
61 Module Domain <: Enumeration.
62
63 Inductive prod : Set := %s
64 .
65
66 Open Scope string_scope.
67 Definition prod_to_string (p : prod) : String.string :=
68 match p with%s
69 end.
70
71 Definition A := prod.
72
73 Lemma eqA_dec : forall x y : A, {x = y} + {x <> y}.
74 Proof.
75 decide_enumeration_equality.
76 Qed.
77
78 Identity Coercion iprod2prod : A >-> prod.
79
80 Definition A_enum : enumeration prod.
81 Proof.
82 provide_enumeration (%s::nil).
83 Qed.
84
85 End Domain."
86 (List.to_string (fun s -> "\n | " ^ prodName s) prods)
87 (List.to_string (fun s -> "\n | " ^ prod2str s) prods)
88 (String.concat_map "::" prodName prods)
89
90 let make_char s = Printf.sprintf "\"%s\"%%char" s
91
92 let coq_char = function
93 | c when Char.code c < 32 -> Printf.sprintf "\"%03d\"%%char" (Char.code c)
94 | '"' -> make_char "\"\""
95 | c -> make_char (String.make 1 c)
96
97 let string2coq s =
98 let escape_char = function
99 | '"' -> "\"\""
100 | '\n' | '\t' | '\r' -> failwith (Printf.sprintf "Unsupported escape sequence in string: %s" s)
101 | c -> String.make 1 c
102 in
103 let chars = String.char_list_of_string s in
104 let coq_chars = List.map escape_char chars in
105 String.concat "" coq_chars
106
107 let prefix2str = function
108 | `AND -> "[&]"
109 | `NOT -> "[!]"
110 | `NORMAL -> ""
111
112 let suffix2str = function
113 | `QUESTION -> "[?]"
114 | `STAR -> "[*]"
115 | `PLUS -> "[+]"
116 | `NORMAL -> ""
117
118 let primary_as_seq p =
119 let item = `NORMAL, p, `NORMAL in
120 [item], StringMap.empty, None
121
122 let rec range2str = function
123 | [T.Any] -> "[.]"
124 | [T.Range (c1, c2)] -> Printf.sprintf "[|%s -- %s|]" (coq_char c1) (coq_char c2)
125 (* TODO, improve that: *)
126 | [T.One c] when Char.code c < 32 || c == '"' -> Printf.sprintf "%s" (coq_char c)
127 | [T.One c] -> Printf.sprintf "\"%c\"" c
128 | ls ->
129 let es = expr2str (P.Expr (List.map (fun s -> primary_as_seq (P.Class [s])) ls)) in
130 Printf.sprintf "(%s)" es
131
132 and primary2str = function
133 | P.Ident i -> prodName i
134 | P.Paren exp -> "(" ^ expr2str exp ^ ")"
135 | P.Literal (l, true) ->
136 if String.length l = 1 then
137 primary2str (P.Class [T.One l.[0]])
138 else
139 Printf.sprintf "\"%s\"" (string2coq l)
140 | P.Literal (l, false) -> failwith "case-insensitive literals for now unsupported by certified TRX :|"
141 | P.Class cs -> range2str cs
142
143 (* TODO Smarter parenthesization, i.e. put them only where neccessary *)
144 and item2str (prefix, primary, suffix) =
145 prefix2str prefix ^ primary2str primary ^ suffix2str suffix
146
147 and seq2str (items, _, _) = String.concat_map "; " item2str items
148
149 and expr2str = function
150 | P.Expr es -> String.concat_map " / " seq2str es
151 | P.App _ -> failwith "trx2cert :: expr2str :: App"
152
153 let production2str name (expr, _) acc =
154 Printf.sprintf "%s\n | %s => %s" acc (prodName name) (expr2str expr.P.expression)
155
156 let grammar peg name =
157 let module_name = String.uncapitalize name in
158 let moduleName = String.capitalize name in
159 module_prefix := moduleName;
160 Printf.sprintf "
161 Module %s_Grammar <: PEG_spec.
162
163 Module PD <: PEG_domain.
164 Module Export PS := Domain.
165 Definition prod_type (p : prod) : Type := True.
166 End PD.
167
168 Module Export PE := ParsingExpressions PD.
169 Open Scope peg_scope.
170
171 Definition prod_coercion (p : prod) : pexp := nonTerminal p.
172 Coercion prod_coercion : prod >-> pexp.
173
174 Definition preproduction (p : prod) : pexp :=
175 match p with%s
176 end.
177
178 Definition production : prod -> PExp True :=
179 fun p => promote (preproduction p).
180
181 Definition start := %s.
182
183 End %s_Grammar.
184
185 Module %s_Parser := TRX %s_Grammar.
186
187 Definition build_%s_parser := %s_Parser.build_parser.
188 "
189 moduleName
190 (StringMap.fold production2str peg.T.grammar "")
191 (prodName peg.T.start) moduleName moduleName moduleName module_name
192 moduleName
193
194 let _ =
195 if Array.length Sys.argv < 2 then
196 Printf.eprintf "Usage: %s [grammar].trx\n" Sys.argv.(0)
197 else
198 let grammarFn = Sys.argv.(1) in
199 try
200 let peg, _ = Pgrammar.read_grammar ~verbose:true None grammarFn in
201 Printf.printf "%s%s\n%s\n" (header ()) (domain peg) (grammar peg (File.module_name grammarFn))
202 with
203 | Pgrammar.GrammarParse err ->
204 Printf.eprintf "Failed while parsing the input grammar: {%s}!\n" grammarFn
Something went wrong with that request. Please try again.