Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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