Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 278 lines (258 sloc) 10.507 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 *)
21
22 (* HACK : please, clean-up in opa lang *)
23 module Parser_utils = OpaParserUtils
24
25 open Base
26 open SurfaceAst
27 module C = SurfaceAstCons.StringCons
28 module I = Opacapi
29 let fresh_name = Parser_utils.fresh_name
30 let (!) = C.E.ident
31 let (&) = C.E.applys
32
33 let option_bind e (pat,expr) =
34 C.E.match_opt e
35 (C.P.none (), C.E.none ())
36 (C.P.some pat, expr)
37
38 let pattern_of_opt = function
39 | None -> C.P.any ()
40 | Some name -> C.P.ident name
41
42 let try_parse_opt () =
43 C.E.dot !"Parser" "try_parse_opt"
44 let try_parse () =
45 C.E.dot !"Parser" "try_parse"
46 let flatten_and_discard_whitespace_list () =
47 C.E.dot !"Xml_parser" "flatten_and_discard_whitespace_list"
48
49 (*
50 let may_be_compatible patterns1 patterns2 =
51 match patterns1, patterns2 with
52 | [], _
53 | _, [] -> assert false (* cannot parse empty sequences *)
54 | p1 :: _, p2 :: _ ->
55 match p1, p2 with
56 | XmlNode _, XmlParser _ -> false
57 | XmlParser _, XmlNode _ -> false
58 | XmlNode ({namespace=(ns1,_);name=(n1,_)},_,_),
59 XmlNode ({namespace=(ns2,_);name=(n2,_)},_,_) ->
60 ns1 = ns2 && n1 = n2
61 | XmlAny, _
62 | _, XmlAny
63 | XmlExpr _, _
64 | _, XmlExpr _ -> true
65 | XmlParser _, XmlParser _ ->
66 true (* FIXME: actually, we should regroup these two parsers
67 * into one, so that trx can compile it possibly in a smarter way *)
68 *)
69
70 let process_attribute name (attr,name_opt,attr_check) content =
71 let expr = !I.Xml.find_attr & [!name; attr.namespace; Parser_utils.string2 attr.name] in
72 let bound_ident =
73 match name_opt with
74 | None -> C.P.ident ~label:(snd attr.name) (fst attr.name)
75 | Some bound_name -> C.P.ident bound_name in
76 let attrParser parser_ =
77 let val_name = Parser_utils.fresh_name ~name:"value" () in
78 let match_attr content =
79 C.E.match_opt expr
80 (C.P.none (), C.E.none ())
81 (C.P.some (C.P.ident val_name), content) in
82 let match_attr_val =
83 C.E.match_opt (try_parse () & [parser_; !val_name])
84 (C.P.none (), C.E.none ())
85 (C.P.some bound_ident, content) in
86 match_attr match_attr_val
87 in
88 match attr_check with
89 | XmlAttrStringParser se ->
90 (* convert the string to a parser (no more magic for that) *)
91 attrParser (!I.Parser.of_string & [se])
92 | XmlAttrParser parser_ -> attrParser parser_
93 | XmlExists ->
94 C.E.match_opt expr
95 (C.P.none (), C.E.none ())
96 (C.P.some (C.P.any ()), content)
97 | XmlName ->
98 C.E.match_opt expr
99 (C.P.none (), C.E.none ())
100 (C.P.some bound_ident, content)
101
102 let process_attributes (name:string) list content =
103 List.fold_right (fun attr_node acc ->
104 process_attribute name attr_node acc
105 ) list content
106
107 let error_suffix_anonymous_parser annot =
108 let context = OpaError.Context.annot annot in
109 OpaError.error context (
110 "You cannot have a @{<bright>suffix@} on a tag.@\n"^^
111 "@[<2>@{<bright>Hint@}:@\nPlease use an @{<bright>anonymous@} parser instead.@]@\n"
112 )
113
114 let rec process_named_pattern named_pattern l tl acc =
115 match (named_pattern : _ xml_named_pattern) with
116 | (name, XmlLetIn (bindings, subpattern), suffix) ->
117 C.E.letand bindings (process_named_pattern (name, subpattern, suffix) l tl acc)
118 | (name, XmlAny, suffix) ->
119 ( match suffix with
120 | None ->
121 C.E.match_ !l
122 [ C.P.nil (), C.E.none ()
123 ; C.P.hd_tl (pattern_of_opt name) (C.P.var tl), acc ]
124 | Some (Xml_star,_) ->
125 let acc = C.E.letin tl (C.E.nil ()) acc in
126 ( match name with
127 | None -> acc
128 | Some name -> C.E.letin name !l acc
129 )
130 | Some (Xml_plus,_) ->
131 let acc = C.E.letin tl (C.E.nil ()) acc in
132 C.E.match_ !l
133 [ C.P.nil (), C.E.none ()
134 ; C.P.hd_tl (C.P.any ()) (C.P.any ()),
135 (match name with
136 | None -> acc
137 | Some name -> C.E.letin name !l acc)]
138 | Some (Xml_question,_) ->
139 let i = fresh_name ~name:"question" () in
140 let v =
141 C.E.match_ !l
142 [ C.P.nil (), C.E.tuple_2 (C.E.none ()) (C.E.nil ())
143 ; C.P.hd_tl (C.P.ident "hd") (C.P.ident "tl"), C.E.tuple_2 (C.E.some !"hd") !"tl"] in
144 C.E.letin i v
145 (C.E.match_ !i
146 [ C.P.tuple_2 (pattern_of_opt name) (C.P.ident tl), acc ])
147 | Some (Xml_number e,_) ->
148 C.E.match_opt (C.E.applys !I.Xml.split [e;!l])
149 (C.P.none (), C.E.none ())
150 (C.P.some (C.P.tuple_2 (pattern_of_opt name) (C.P.ident tl)), acc)
151 | Some (Xml_range (e1,e2),_) ->
152 C.E.match_opt (C.E.applys !I.Xml.split_between [!l;e1;e2])
153 (C.P.none (), C.E.none ())
154 (C.P.some (C.P.tuple_2 (pattern_of_opt name) (C.P.ident tl)), acc)
155 )
156 | (name, XmlExpr e, suffix) ->
157 let res =
158 match suffix with
159 | None -> C.E.applys e [!l]
160 | Some (Xml_star,_) -> C.E.applys !I.Xml.match_star [e; !l]
161 | Some (Xml_plus,_) -> C.E.applys !I.Xml.match_plus [e; !l]
162 | Some (Xml_question,_) -> C.E.applys !I.Xml.match_question [e; !l]
163 | Some (Xml_number e1,_) -> C.E.applys !I.Xml.match_number [e; e1; !l]
164 | Some (Xml_range (e1,e2),_) -> C.E.applys !I.Xml.match_range [e; e1; e2; !l] in
165 C.E.match_opt res
166 (C.P.none (), C.E.none ())
167 (C.P.some (C.P.tuple_2 (pattern_of_opt name) (C.P.ident tl)), acc)
168 | (_name,XmlNode (tag,attr,children),suffix) -> (
169 match suffix with
170 | None ->
171 let mkstring (string,label) = C.P.string ~label string in
172 let attrs = fresh_name ~name:"attrs" () in
173 let args = fresh_name ~name:"args" () in
174 let ns = fresh_name ~name:"ns" () in
175 let k e =
176 C.E.match_ !l
177 [ C.P.hd_tl (
178 C.P.coerce_name
179 (C.P.record [ "namespace", C.P.var ns
180 ; "tag", mkstring tag.name
181 ; "args", (if attr = [] then C.P.any () else C.P.var attrs)
182 ; "content", (if children = [] then C.P.any () else C.P.var args)
183 ; "specific_attributes", C.P.any ()])
184 Opacapi.Types.xml
185 ) (C.P.ident tl), e
186 ; C.P.any (), C.E.none () ] in
187 let k e =
188 k (
189 C.E.if_ (C.E.applys !I.(==) [tag.namespace; C.E.var ns])
190 e
191 (C.E.none ())
192 ) in
193 k (
194 if children = [] then (
195 process_attributes attrs attr
196 acc
197 ) else (
198 let last_name = fresh_name ~name:"dontcare" () in
199 process_attributes attrs attr
200 (C.E.letin args (flatten_and_discard_whitespace_list () & [!args])
201 (process_named_patterns args children last_name
202 acc))
203 )
204 )
205 | Some (_suffix,annot) ->
206 (* instance of error: xml_parser <mlk> <mlk/>* </> -> {}
207 * happens because in xml_parser <mlk> <mlk a=_/>* </>, what should be the type of a?
208 * each nesting inside a star/plus/... could create a list, but it isn't
209 * done and it hasn't been asked for *)
210 error_suffix_anonymous_parser annot
211 )
212 | (_, XmlParser _, Some (_suffix,annot)) ->
213 (* same problem as above, XmlParser may bind variables *)
214 error_suffix_anonymous_parser annot
215 | (name, XmlParser items, None) ->
216 assert (name = None); (* see the parser *)
217 let item = List.hd items in
218 let trx_expr =
219 (Trx_ast.Expr
220 [({ Trx_ast.seq_items = items
221 ; Trx_ast.seq_code = Some acc },
222 Parser_utils.nlabel item)], Parser_utils.nlabel item) in
223 let p = fresh_name ~name:"p" () in
224 let res = fresh_name ~name:"res" () in
225 C.E.match_ !l
226 [ C.P.hd_tl
227 (C.P.coerce_name (C.P.record ["text", C.P.var res]) Opacapi.Types.xml)
228 (C.P.var tl),
229 C.E.letin p (SurfaceAstTrx.translate_rule trx_expr)
230 (try_parse_opt () & [C.E.var p; C.E.var res])
231 ; C.P.any (), C.E.none () ]
232
233 and process_named_patterns name named_patterns last_name e : (_,_) expr =
234 let acc, _ =
235 List.fold_right_i
236 (fun (named_pattern : _ xml_named_pattern) i (acc,tl) ->
237 let l = if i = 0 then name else fresh_name ~name:"l" () in
238 (process_named_pattern named_pattern l tl acc,l)
239 ) named_patterns (e,last_name) in
240 acc
241
242 (* FIXME: imcompatible patterns could be merged in one pattern
243 * xml_parser
244 * | <mlk/> -> ...
245 * | <poi/> -> ...
246 * could be compiled to
247 * match xmls with
248 * | [<mlk/>|rest] -> ...
249 * | [<poi/>|rest] -> ... /* no backtracking possible between those two cases */
250 * | _ -> ...
251 *)
252 let process_rule name (patterns,e) : (_,_) expr =
253 let last_name = fresh_name ~name:"last_name" () in
254 let res = C.E.some (C.E.tuple_2 e (C.E.ident last_name)) in
255 process_named_patterns name patterns last_name res
256
257 let process_rules name l =
258 let last_none = C.E.none () in
259 List.fold_right_i
260 (fun rule_ i acc ->
261 let n = fresh_name ~name:(Printf.sprintf "case_%d" i) () in
262 if acc == last_none then
263 process_rule name rule_ (* avoid a stupid match *)
264 else
265 C.E.letin n (process_rule name rule_)
266 (C.E.match_opt !n
267 (C.P.none (), acc)
268 (C.P.ident "res", !"res"))) l last_none
269
270 let process_parser _e rules =
271 #<If:SA_XML_PATTERN>
272 Format.printf "%a@." OpaPrint.string#expr _e
273 #<End>;
274 let xmls = fresh_name ~name:"xmls" () in
275 let body = process_rules xmls rules in
276 let body = Parser_utils.around_xmlns body in
277 C.E.lambda_var xmls body
Something went wrong with that request. Please try again.