| 1 |
#load "pa_extend.cmo";;
|
| 2 |
|
| 3 |
open Cduce_loc
|
| 4 |
(* let raise = Pervasives.raise *)
|
| 5 |
open Ast
|
| 6 |
open Ident
|
| 7 |
open Printf
|
| 8 |
open Ulexer
|
| 9 |
|
| 10 |
(*
|
| 11 |
let () = Grammar.error_verbose := true
|
| 12 |
*)
|
| 13 |
|
| 14 |
let tloc (i,j) = (i,j)
|
| 15 |
let nopos = (-1,-1)
|
| 16 |
|
| 17 |
|
| 18 |
let mk loc x = Cduce_loc.mk_located (tloc loc) x
|
| 19 |
|
| 20 |
exception Error of string
|
| 21 |
let error (i,j) s = Cduce_loc.raise_loc i j (Error s)
|
| 22 |
let error loc s = error (tloc loc) s
|
| 23 |
|
| 24 |
module Gram = Camlp4.Struct.Grammar.Static.Make(Ulexer)
|
| 25 |
|
| 26 |
let id_dummy = U.mk "$$$"
|
| 27 |
|
| 28 |
let ident s =
|
| 29 |
let b = Buffer.create (String.length s) in
|
| 30 |
let rec aux i =
|
| 31 |
if (i = String.length s) then Buffer.contents b
|
| 32 |
else match s.[i] with
|
| 33 |
| '\\' -> assert (s.[i+1] = '.'); Buffer.add_char b '.'; aux (i+2)
|
| 34 |
| c -> Buffer.add_char b c; aux (i+1)
|
| 35 |
in
|
| 36 |
aux 0
|
| 37 |
|
| 38 |
let label s = U.mk (ident s)
|
| 39 |
let ident s = U.mk (ident s)
|
| 40 |
|
| 41 |
let prog = Gram.Entry.mk "prog"
|
| 42 |
let top_phrases = Gram.Entry.mk "toplevel phrases"
|
| 43 |
let expr = Gram.Entry.mk "expression"
|
| 44 |
let pat = Gram.Entry.mk "type/pattern expression"
|
| 45 |
let regexp = Gram.Entry.mk "type/pattern regexp"
|
| 46 |
let keyword = Gram.Entry.mk "keyword"
|
| 47 |
|
| 48 |
let lop pos = Cduce_loc.loc_of_pos (tloc pos)
|
| 49 |
let exp pos e = LocatedExpr (lop pos,e)
|
| 50 |
|
| 51 |
let rec multi_prod loc = function
|
| 52 |
| [ x ] -> x
|
| 53 |
| x :: l -> mk loc (Prod (x, multi_prod loc l))
|
| 54 |
| [] -> assert false
|
| 55 |
|
| 56 |
let rec tuple = function
|
| 57 |
| [ x ] -> x
|
| 58 |
| x :: l -> Pair (x, tuple l)
|
| 59 |
| [] -> assert false
|
| 60 |
|
| 61 |
let tuple_queue =
|
| 62 |
List.fold_right (fun x q -> Pair (x, q))
|
| 63 |
|
| 64 |
|
| 65 |
let char = mknoloc (Internal (Types.char Chars.any))
|
| 66 |
let string_regexp = Star (Elem char)
|
| 67 |
|
| 68 |
let seq_of_string s =
|
| 69 |
let s = Encodings.Utf8.mk s in
|
| 70 |
let rec aux i j =
|
| 71 |
if Encodings.Utf8.equal_index i j then []
|
| 72 |
else let (c,i) = Encodings.Utf8.next s i in c :: (aux i j)
|
| 73 |
in
|
| 74 |
aux (Encodings.Utf8.start_index s) (Encodings.Utf8.end_index s)
|
| 75 |
|
| 76 |
|
| 77 |
let parse_char loc s =
|
| 78 |
match seq_of_string s with
|
| 79 |
| [ c ] -> c
|
| 80 |
| _ -> error loc "Character litteral must have length 1"
|
| 81 |
|
| 82 |
let include_stack = ref []
|
| 83 |
|
| 84 |
let protect_exn f g =
|
| 85 |
try let x = f () in g (); x
|
| 86 |
with e -> g (); raise e
|
| 87 |
|
| 88 |
let localize_exn f =
|
| 89 |
try f ()
|
| 90 |
with
|
| 91 |
| Ulexer.Loc.Exc_located (_, (Location _ as e)) -> raise e
|
| 92 |
(* | Camlp4.PreCast.Loc.Exc_located ((i,j), e) -> raise_loc i j e *)
|
| 93 |
| Ulexer.Loc.Exc_located (loc, e) ->
|
| 94 |
let i, j = Ulexer.Loc.start_off loc, Ulexer.Loc.stop_off loc in
|
| 95 |
raise_loc i j e
|
| 96 |
|
| 97 |
let is_fun_decl =
|
| 98 |
Gram.Entry.of_parser "[is_fun_decl]"
|
| 99 |
(fun strm ->
|
| 100 |
match Stream.npeek 3 strm with
|
| 101 |
| [ KEYWORD "fun", _; IDENT _, _; KEYWORD "(", _ ]
|
| 102 |
| [ IDENT _, _; KEYWORD "(", _; _ ] -> ()
|
| 103 |
| _ -> raise Stream.Failure
|
| 104 |
)
|
| 105 |
|
| 106 |
let is_capture =
|
| 107 |
Gram.Entry.of_parser "[is_capture]"
|
| 108 |
(fun strm ->
|
| 109 |
match Stream.npeek 2 strm with
|
| 110 |
| [ IDENT _, _; KEYWORD "::", _; _ ] -> ()
|
| 111 |
| _ -> raise Stream.Failure
|
| 112 |
)
|
| 113 |
|
| 114 |
|
| 115 |
let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
|
| 116 |
|
| 117 |
let logical_and e1 e2 = if_then_else e1 e2 cst_false
|
| 118 |
let logical_or e1 e2 = if_then_else e1 cst_true e2
|
| 119 |
let logical_not e = if_then_else e cst_false cst_true
|
| 120 |
|
| 121 |
let apply_op2_noloc op e1 e2 = Apply (Apply (Var (ident op), e1), e2)
|
| 122 |
let apply_op2 loc op e1 e2 = exp loc (apply_op2_noloc op e1 e2)
|
| 123 |
|
| 124 |
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set"), e2)
|
| 125 |
let get_ref e = Apply (Dot (e, U.mk "get"), cst_nil)
|
| 126 |
let let_in e1 p e2 = Match (e1, [p,e2])
|
| 127 |
let seq e1 e2 = let_in e1 pat_nil e2
|
| 128 |
let concat e1 e2 = apply_op2_noloc "@" e1 e2
|
| 129 |
|
| 130 |
EXTEND Gram
|
| 131 |
GLOBAL: top_phrases prog expr pat regexp keyword;
|
| 132 |
|
| 133 |
top_phrases: [
|
| 134 |
[ l = LIST0 phrase; ";;" -> List.flatten l ]
|
| 135 |
];
|
| 136 |
|
| 137 |
prog: [
|
| 138 |
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; `EOI -> List.flatten l ]
|
| 139 |
];
|
| 140 |
|
| 141 |
phrase: [
|
| 142 |
[ (f,p,e) = let_binding ->
|
| 143 |
if f then [ mk _loc (FunDecl e) ] else
|
| 144 |
[ mk _loc (LetDecl (p,e)) ]
|
| 145 |
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
|
| 146 |
[ mk _loc (EvalStatement (exp _loc (let_in e1 p e2))) ]
|
| 147 |
| "type"; x = located_ident; "="; t = pat -> [ mk _loc (TypeDecl (x,t)) ]
|
| 148 |
| "using"; name = IDENT; "="; cu = [ x = IDENT -> x | x = STRING2 -> x ] ->
|
| 149 |
[ mk _loc (Using (U.mk name, U.mk cu)) ]
|
| 150 |
| "open"; ids = LIST1 ident_or_keyword SEP "." ->
|
| 151 |
let ids = List.map (fun x -> ident x) ids in
|
| 152 |
[ mk _loc (Open ids) ]
|
| 153 |
| "schema"; name = IDENT; "="; uri = STRING2 ->
|
| 154 |
protect_op "schema";
|
| 155 |
[ mk _loc (SchemaDecl (U.mk name, uri)) ]
|
| 156 |
| n = namespace_binding ->
|
| 157 |
let d = match n with
|
| 158 |
| `Prefix (name,ns) -> Namespace (name, ns)
|
| 159 |
| `Keep b -> KeepNs b in
|
| 160 |
[ mk _loc d ]
|
| 161 |
| n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
|
| 162 |
let e =
|
| 163 |
match n with
|
| 164 |
| `Prefix (name,ns) -> NamespaceIn (name, ns, e2)
|
| 165 |
| `Keep b -> KeepNsIn (b,e2)
|
| 166 |
in
|
| 167 |
[ mk _loc (EvalStatement (exp _loc e)) ]
|
| 168 |
| "debug"; d = debug_directive -> [ mk _loc (Directive (`Debug d)) ]
|
| 169 |
| "#"; IDENT "verbose" -> [ mk _loc (Directive `Verbose) ]
|
| 170 |
| "#"; IDENT "silent" -> [ mk _loc (Directive `Silent) ]
|
| 171 |
| "#"; IDENT "utf8" -> Ulexer.enc := Ulexing.Utf8; [ ]
|
| 172 |
| "#"; IDENT "latin1" -> Ulexer.enc := Ulexing.Latin1; [ ]
|
| 173 |
| "#"; IDENT "ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
|
| 174 |
| "#"; IDENT "quit" -> [ mk _loc (Directive `Quit) ]
|
| 175 |
| "#"; IDENT "env" -> [ mk _loc (Directive `Env) ]
|
| 176 |
| "#"; IDENT "print_type"; t = pat ->
|
| 177 |
[ mk _loc (Directive (`Print_type t)) ]
|
| 178 |
| "#"; IDENT "dump_value"; e = expr -> [ mk _loc (Directive (`Dump e)) ]
|
| 179 |
| "#"; IDENT "reinit_ns" -> [ mk _loc (Directive `Reinit_ns) ]
|
| 180 |
| "#"; IDENT "help" -> [ mk _loc (Directive `Help) ]
|
| 181 |
| "#"; IDENT "builtins" -> [ mk _loc (Directive `Builtins) ]
|
| 182 |
| "include"; s = STRING2 ->
|
| 183 |
protect_op "File inclusion";
|
| 184 |
let s = Cduce_loc.resolve_filename s in
|
| 185 |
(* avoid looping; should issue an error ? *)
|
| 186 |
(* it is possible to have looping with x/../x/../x/.. ....
|
| 187 |
Need to canonicalize filename *)
|
| 188 |
if List.mem s !include_stack then []
|
| 189 |
else (
|
| 190 |
include_stack := s :: !include_stack;
|
| 191 |
Cduce_loc.push_source (`File s);
|
| 192 |
let saved_enc = !Ulexer.enc in
|
| 193 |
Ulexer.enc := Ulexing.Latin1;
|
| 194 |
protect_exn
|
| 195 |
(fun () ->
|
| 196 |
let chan = open_in s in
|
| 197 |
protect_exn
|
| 198 |
(fun () ->
|
| 199 |
let input = Stream.of_channel chan in
|
| 200 |
localize_exn (fun () -> Gram.parse prog Ulexer.Loc.ghost input))
|
| 201 |
(fun () -> close_in chan))
|
| 202 |
(fun () ->
|
| 203 |
Ulexer.enc := saved_enc;
|
| 204 |
Cduce_loc.pop_source ();
|
| 205 |
include_stack := List.tl !include_stack)
|
| 206 |
)
|
| 207 |
] |
|
| 208 |
[ e = expr -> [ mk _loc (EvalStatement e) ]
|
| 209 |
]
|
| 210 |
];
|
| 211 |
|
| 212 |
debug_directive: [
|
| 213 |
[ IDENT "filter"; t = pat; p = pat -> `Filter(t,p)
|
| 214 |
| IDENT "accept"; p = pat -> `Accept p
|
| 215 |
| IDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
|
| 216 |
| IDENT "sample"; t = pat -> `Sample t
|
| 217 |
| IDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
|
| 218 |
| IDENT "single"; t = pat -> `Single t
|
| 219 |
]
|
| 220 |
];
|
| 221 |
|
| 222 |
keyword: [
|
| 223 |
[ a =
|
| 224 |
[ "map" | "match" | "with" | "try" | "xtransform"
|
| 225 |
| "if" | "then" | "else"
|
| 226 |
| "transform" | "fun" | "in"
|
| 227 |
| "let" | "type" | "debug" | "include"
|
| 228 |
| "and" | "or" | "validate" | "schema" | "namespace" | "ref" | "alias"
|
| 229 |
| "not" | "as" | "where" | "select" | "from" | "open"
|
| 230 |
]
|
| 231 |
-> a
|
| 232 |
]
|
| 233 |
];
|
| 234 |
|
| 235 |
ident_or_keyword: [
|
| 236 |
[ s = IDENT -> s
|
| 237 |
| s = keyword -> s ]
|
| 238 |
];
|
| 239 |
|
| 240 |
expr: [
|
| 241 |
"top" RIGHTA
|
| 242 |
[ "match"; e = SELF; "with"; b = branches ->
|
| 243 |
exp _loc (Match (e,b))
|
| 244 |
| "try"; e = SELF; "with"; b = branches ->
|
| 245 |
exp _loc (Try (e,b))
|
| 246 |
| "map"; e = SELF; "with"; b = branches ->
|
| 247 |
exp _loc (Map (e,b))
|
| 248 |
| "xtransform"; e = SELF; "with"; b = branches ->
|
| 249 |
exp _loc (Xtrans (e,b))
|
| 250 |
| "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
|
| 251 |
exp _loc (if_then_else e e1 e2)
|
| 252 |
| "transform"; e = SELF; "with"; b = branches ->
|
| 253 |
exp _loc (Transform (e,b))
|
| 254 |
| "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
|
| 255 |
exp _loc (Validate (e, [schema;typ]))
|
| 256 |
| "select"; e = SELF; "from";
|
| 257 |
l = LIST1 [ x = pat ; "in"; e = expr -> (x,e)] SEP "," ;
|
| 258 |
cond = [ "where"; c = LIST1 [ expr ] SEP "and" -> c
|
| 259 |
| -> [] ] -> exp _loc (SelectFW (e,l,cond))
|
| 260 |
| "fun"; (f,a,b) = fun_decl ->
|
| 261 |
exp _loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
|
| 262 |
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
|
| 263 |
exp _loc (let_in e1 p e2)
|
| 264 |
| n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
|
| 265 |
(match n with
|
| 266 |
| `Prefix (name,ns) -> exp _loc (NamespaceIn (name, ns, e2))
|
| 267 |
| `Keep f -> exp _loc (KeepNsIn (f,e2)))
|
| 268 |
| e = expr; ":"; p = pat ->
|
| 269 |
exp _loc (Forget (e,p))
|
| 270 |
| e = expr; ":"; "?"; p = pat ->
|
| 271 |
exp _loc (Check (e,p))
|
| 272 |
| e1 = expr; ";"; e2 = expr ->
|
| 273 |
exp _loc (seq e1 e2)
|
| 274 |
| "ref"; p = pat; e = expr ->
|
| 275 |
exp _loc (Ref (e,p))
|
| 276 |
| "not"; e = expr -> exp _loc (logical_not e)
|
| 277 |
]
|
| 278 |
|
|
| 279 |
[ e1 = expr; ":="; e2 = expr -> exp _loc (set_ref e1 e2)
|
| 280 |
]
|
| 281 |
|
|
| 282 |
[ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr ->
|
| 283 |
let op = match op with
|
| 284 |
| "<<" -> "<"
|
| 285 |
| ">>" -> ">"
|
| 286 |
| s -> s in
|
| 287 |
apply_op2 _loc op e1 e2
|
| 288 |
]
|
| 289 |
|
| 290 |
|
|
| 291 |
[ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 _loc op e1 e2
|
| 292 |
| e1 = expr; ["||" | "or"]; e2 = expr -> exp _loc (logical_or e1 e2)
|
| 293 |
| e = expr; "\\"; l = ident_or_keyword ->
|
| 294 |
exp _loc (RemoveField (e, label l))
|
| 295 |
]
|
| 296 |
|
|
| 297 |
[ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 _loc op e1 e2
|
| 298 |
| e1 = expr; "&&"; e2 = expr -> exp _loc (logical_and e1 e2)
|
| 299 |
| e = expr; op = "/"; p = pat LEVEL "simple" ->
|
| 300 |
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
|
| 301 |
let tag = mk _loc (Internal (Types.atom (Atoms.any))) in
|
| 302 |
let att = mk _loc (Internal Types.Record.any) in
|
| 303 |
let any = mk _loc (Internal Types.any) in
|
| 304 |
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
|
| 305 |
let ct = mk _loc (Regexp re) in
|
| 306 |
let p = mk _loc (XmlT (tag, multi_prod _loc [att;ct])) in
|
| 307 |
exp _loc (Transform (e,[p, Var id_dummy]))
|
| 308 |
| e = expr; "/@"; a = ident_or_keyword ->
|
| 309 |
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
|
| 310 |
let tag = mk _loc (Internal (Types.atom Atoms.any)) in
|
| 311 |
let any = mk _loc (Internal Types.any) in
|
| 312 |
let att = mk _loc (Record
|
| 313 |
(true, [(label a,
|
| 314 |
(mk _loc (PatVar [id_dummy]),
|
| 315 |
None))])) in
|
| 316 |
let p = mk _loc (XmlT (tag, multi_prod _loc [att;any])) in
|
| 317 |
let t = (p, Pair (Var id_dummy,cst_nil)) in
|
| 318 |
exp _loc (Transform (e,[t]))
|
| 319 |
| e = expr; "//" ; p = pat ->
|
| 320 |
(* let $xstack=ref [p*] [] in
|
| 321 |
let f ( x : [Any*]) : [Any*] =
|
| 322 |
xtransform x with $$$ & p & <_ ..>[y::Any* ] -> $stack := !$stack @ [$$$] ; f y
|
| 323 |
in let _ =f e in !$stack *)
|
| 324 |
|
| 325 |
let stk = U.mk "$stack" in
|
| 326 |
let y = U.mk "y" in
|
| 327 |
let x = U.mk "x" in
|
| 328 |
let f = U.mk "f" in
|
| 329 |
let assign =
|
| 330 |
set_ref
|
| 331 |
(Var stk)
|
| 332 |
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
|
| 333 |
let tag = mknoloc (Internal (Types.atom (Atoms.any))) in
|
| 334 |
let att = mknoloc (Internal Types.Record.any) in
|
| 335 |
let any = mknoloc (Internal Types.any) in
|
| 336 |
let re = (SeqCapture(noloc,y,Star(Elem(any)))) in
|
| 337 |
let ct = mknoloc (Regexp re) in
|
| 338 |
let children = mknoloc (XmlT (tag, multi_prod _loc [att;ct])) in
|
| 339 |
let capt = mknoloc (And (mknoloc (And (mknoloc (PatVar [id_dummy]),p)),children)) in
|
| 340 |
let assign = seq assign ( (Apply(Var(f) , Var(y) ) ) ) in
|
| 341 |
let xt = Xtrans ((Var x),[capt,assign]) in
|
| 342 |
let rf = Ref (cst_nil, mknoloc (Regexp (Star(Elem p)))) in
|
| 343 |
let targ = mknoloc (Regexp(Star(Elem(any)))) in
|
| 344 |
let tres = targ in
|
| 345 |
let arg = mknoloc(PatVar [x]) in
|
| 346 |
let abst = {fun_name = Some (lop _loc,ident "f") ; fun_iface = [(targ, tres)] ;fun_body = [(arg,xt)] } in
|
| 347 |
let body =
|
| 348 |
let_in rf (mknoloc (PatVar [stk]))
|
| 349 |
(let_in ((Abstraction abst)) (mknoloc (PatVar[ident "f"]))
|
| 350 |
(let_in ((Apply(Var(f) , e) ) ) (mknoloc (Internal Types.any)) (get_ref (Var stk))))
|
| 351 |
in
|
| 352 |
exp _loc body
|
| 353 |
]
|
| 354 |
| [
|
| 355 |
e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 _loc "/" e1 e2
|
| 356 |
| e1 = SELF; IDENT "mod"; e2 = expr -> apply_op2 _loc "mod" e1 e2
|
| 357 |
| e1 = SELF; e2 = expr -> exp _loc (Apply (e1,e2))
|
| 358 |
]
|
| 359 |
|
| 360 |
| "no_appl"
|
| 361 |
|
| 362 |
[ e = expr; "."; l = ident_or_keyword;
|
| 363 |
tyargs = [ "with"; "{"; tyargs = LIST0 pat; "}" -> Some tyargs
|
| 364 |
| -> None ] ->
|
| 365 |
let e = Dot (e,label l) in
|
| 366 |
match tyargs with None -> exp _loc e | Some tyargs ->
|
| 367 |
exp _loc (TyArgs (e,tyargs))
|
| 368 |
]
|
| 369 |
| [
|
| 370 |
"("; l = LIST1 expr SEP ","; ")" -> exp _loc (tuple l)
|
| 371 |
| "["; l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ];
|
| 372 |
loc_end = ["]" -> _loc] ->
|
| 373 |
let e = match e with Some e -> e | None -> cst_nil in
|
| 374 |
let e = exp loc_end e in
|
| 375 |
let (_,loc_end) = loc_end in
|
| 376 |
let l = List.fold_right
|
| 377 |
(fun x q ->
|
| 378 |
match x with
|
| 379 |
| `String (loc,i,j,s) -> exp loc (String (i,j,s,q))
|
| 380 |
| `Elems ((loc,_),x) -> exp (loc,loc_end) (Pair(x,q))
|
| 381 |
| `Explode x -> concat x q
|
| 382 |
) l e
|
| 383 |
in
|
| 384 |
exp _loc l
|
| 385 |
| "<"; t = [ "("; e = expr; ")" -> e
|
| 386 |
| a = tag -> exp _loc a
|
| 387 |
];
|
| 388 |
a = expr_attrib_spec; ">"; c = expr ->
|
| 389 |
exp _loc (Xml (t, Pair (a,c)))
|
| 390 |
| "{"; r = expr_record_spec; "}" -> r
|
| 391 |
| s = STRING2 ->
|
| 392 |
let s = U.mk s in
|
| 393 |
exp _loc (String (U.start_index s, U.end_index s, s, cst_nil))
|
| 394 |
| a = IDENT -> exp _loc (Var (ident a))
|
| 395 |
| "!"; e = expr -> exp _loc (get_ref e)
|
| 396 |
| i = INT -> exp _loc (Integer (Intervals.V.mk i))
|
| 397 |
| "`"; a = tag -> a
|
| 398 |
| c = char -> exp _loc (Char c)
|
| 399 |
]
|
| 400 |
|
| 401 |
];
|
| 402 |
|
| 403 |
tag: [ [ a = ident_or_keyword -> exp _loc (Atom (ident a)) ] ];
|
| 404 |
|
| 405 |
tag_type: [
|
| 406 |
[ "_" -> mk _loc (Internal (Types.atom Atoms.any))
|
| 407 |
| a = ident_or_keyword -> mk _loc (Cst (Atom (ident a)))
|
| 408 |
| t = ANY_IN_NS -> mk _loc (NsT (ident t))
|
| 409 |
]
|
| 410 |
];
|
| 411 |
|
| 412 |
seq_elem: [
|
| 413 |
[ x = STRING1 ->
|
| 414 |
let s = U.mk x in
|
| 415 |
`String (_loc, U.start_index s, U.end_index s, s)
|
| 416 |
| e = expr LEVEL "no_appl" -> `Elems (_loc,e)
|
| 417 |
| "!"; e = expr LEVEL "no_appl" -> `Explode e
|
| 418 |
]
|
| 419 |
];
|
| 420 |
|
| 421 |
namespace_binding: [
|
| 422 |
[ "namespace"; r = [
|
| 423 |
[ name =
|
| 424 |
[ name = ident_or_keyword; "=" -> ident name
|
| 425 |
| -> U.mk "" ];
|
| 426 |
ns = ns_expr -> `Prefix (name,ns)
|
| 427 |
| IDENT "on" -> `Keep true
|
| 428 |
| IDENT "off" -> `Keep false ]
|
| 429 |
] -> r ]
|
| 430 |
];
|
| 431 |
|
| 432 |
ns_expr: [
|
| 433 |
[ uri = STRING2 -> `Uri (Ns.Uri.mk (ident uri))
|
| 434 |
| ids = LIST1 ident_or_keyword SEP "." ->
|
| 435 |
let ids = List.map (fun x -> ident x) ids in
|
| 436 |
`Path ids ]
|
| 437 |
];
|
| 438 |
|
| 439 |
|
| 440 |
let_binding: [
|
| 441 |
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
|
| 442 |
let f = match f with Some x -> x | None -> assert false in
|
| 443 |
let p = mk _loc (PatVar [snd f]) in
|
| 444 |
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
|
| 445 |
let e = exp _loc (Abstraction abst) in
|
| 446 |
(true,p,e)
|
| 447 |
| "let"; p = pat; "="; e = expr -> (false,p,e)
|
| 448 |
| "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
|
| 449 |
| "let"; p = pat; ":"; "?"; t = pat; "="; e = expr ->
|
| 450 |
(false,p, Check (e,t))
|
| 451 |
]
|
| 452 |
];
|
| 453 |
|
| 454 |
fun_decl_after_lparen: [
|
| 455 |
(* need an hack to do this, because both productions would
|
| 456 |
match [ OPT IDENT; "("; pat ] .... *)
|
| 457 |
[ p1 = pat LEVEL "no_arrow";
|
| 458 |
res = [ "->"; p2 = pat;
|
| 459 |
a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
|
| 460 |
")"; b = branches -> `Classic (p2,a,b)
|
| 461 |
| ":"; targ1 = pat;
|
| 462 |
args = LIST0 [ ","; arg = pat; ":"; targ = pat -> (arg,targ) ];
|
| 463 |
")";
|
| 464 |
others = LIST0
|
| 465 |
[ "(";
|
| 466 |
args =
|
| 467 |
LIST1
|
| 468 |
[ arg = pat; ":"; targ = pat -> (arg,targ) ]
|
| 469 |
SEP ",";
|
| 470 |
")" -> args ];
|
| 471 |
":"; tres = pat ;
|
| 472 |
"="; body = expr ->
|
| 473 |
`Compact (targ1,args,others,tres,body)
|
| 474 |
] ->
|
| 475 |
match res with
|
| 476 |
| `Classic (p2,a,b) -> (p1,p2)::a,b
|
| 477 |
| `Compact (targ1,args,others,tres,body) ->
|
| 478 |
let mkfun args =
|
| 479 |
multi_prod nopos (List.map snd args),
|
| 480 |
multi_prod nopos (List.map fst args)
|
| 481 |
in
|
| 482 |
let (tres,body) =
|
| 483 |
List.fold_right
|
| 484 |
(fun args (tres,body) ->
|
| 485 |
let (targ,arg) = mkfun args in
|
| 486 |
let e = Abstraction
|
| 487 |
{ fun_name = None; fun_iface = [targ,tres];
|
| 488 |
fun_body = [arg,body] } in
|
| 489 |
let t = mknoloc (Arrow (targ,tres)) in
|
| 490 |
(t,e)
|
| 491 |
)
|
| 492 |
others (tres,body) in
|
| 493 |
let (targ,arg) = mkfun ((p1,targ1) :: args) in
|
| 494 |
[(targ,tres)],[(arg,body)]
|
| 495 |
] ];
|
| 496 |
|
| 497 |
|
| 498 |
fun_decl: [
|
| 499 |
[ f = OPT located_ident; "("; (a,b) = fun_decl_after_lparen ->
|
| 500 |
(f,a,b)
|
| 501 |
]
|
| 502 |
];
|
| 503 |
|
| 504 |
arrow: [
|
| 505 |
[ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
|
| 506 |
];
|
| 507 |
|
| 508 |
branches: [
|
| 509 |
[ OPT "|"; l = LIST1 branch SEP "|" -> l ]
|
| 510 |
];
|
| 511 |
|
| 512 |
branch: [
|
| 513 |
[ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
|
| 514 |
];
|
| 515 |
|
| 516 |
|
| 517 |
regexp: [
|
| 518 |
[ x = regexp; "|"; y = regexp ->
|
| 519 |
match (x,y) with
|
| 520 |
| Elem x, Elem y -> Elem (mk _loc (Or (x,y)))
|
| 521 |
| _ -> Alt (x,y)
|
| 522 |
]
|
| 523 |
| [ x = regexp; y = regexp -> Seq (x,y) ]
|
| 524 |
| [ x = regexp; "&"; y = regexp ->
|
| 525 |
match (x,y) with
|
| 526 |
| Elem x, Elem y -> Elem (mk _loc (And (x,y)))
|
| 527 |
| _ -> error _loc "Conjunction not allowed in regular expression"
|
| 528 |
]
|
| 529 |
| [ a = IDENT; "::"; x = regexp -> SeqCapture (lop _loc,ident a,x) ]
|
| 530 |
| [ x = regexp; "*" -> Star x
|
| 531 |
| x = regexp; "*?" -> WeakStar x
|
| 532 |
| x = regexp; "+" -> Seq (x, Star x)
|
| 533 |
| x = regexp; "+?" -> Seq (x, WeakStar x)
|
| 534 |
| x = regexp; "?" -> Alt (x, Epsilon)
|
| 535 |
| x = regexp; "??" -> Alt (Epsilon, x)
|
| 536 |
| x = regexp; "**"; i = INT ->
|
| 537 |
let rec aux i accu =
|
| 538 |
if (i = 0) then accu
|
| 539 |
else aux (pred i) (Seq (x, accu))
|
| 540 |
in
|
| 541 |
let i =
|
| 542 |
try
|
| 543 |
let i = int_of_string i in
|
| 544 |
if (i > 1024) then raise Exit else i
|
| 545 |
(* We cannot handle type that huge... *)
|
| 546 |
with Failure _ | Exit -> error _loc "Repetition number too large"
|
| 547 |
in
|
| 548 |
if (i <= 0) then
|
| 549 |
error _loc "Repetition number must be a positive integer";
|
| 550 |
aux i Epsilon
|
| 551 |
]
|
| 552 |
| [ "("; x = LIST1 regexp SEP ","; ")" ->
|
| 553 |
(match x with
|
| 554 |
| [ x ] -> x
|
| 555 |
| _ ->
|
| 556 |
let x =
|
| 557 |
List.map
|
| 558 |
(function
|
| 559 |
| Elem x -> x
|
| 560 |
| _ -> error _loc
|
| 561 |
"Mixing regular expressions and products")
|
| 562 |
x in
|
| 563 |
Elem (multi_prod _loc x))
|
| 564 |
| "("; a = IDENT; ":="; c = expr; ")" ->
|
| 565 |
Elem (mk _loc (Constant ((ident a,c))))
|
| 566 |
| "/"; p = pat LEVEL "simple" -> Guard p
|
| 567 |
| IDENT "PCDATA" -> string_regexp
|
| 568 |
| i = STRING1; "--"; j = STRING1 ->
|
| 569 |
let i = Chars.V.mk_int (parse_char _loc i)
|
| 570 |
and j = Chars.V.mk_int (parse_char _loc j) in
|
| 571 |
Elem (mk _loc (Internal (Types.char (Chars.char_class i j))))
|
| 572 |
| s = STRING1 ->
|
| 573 |
List.fold_right
|
| 574 |
(fun c accu ->
|
| 575 |
let c = Chars.V.mk_int c in
|
| 576 |
let c = Chars.atom c in
|
| 577 |
Seq (Elem (mknoloc (Internal (Types.char c))), accu))
|
| 578 |
(seq_of_string s)
|
| 579 |
Epsilon ]
|
| 580 |
| [ e = pat LEVEL "simple" -> Elem e
|
| 581 |
]
|
| 582 |
];
|
| 583 |
|
| 584 |
schema_ref: [
|
| 585 |
[ schema = IDENT; "."; typ = ident_or_keyword -> (U.mk schema, ident typ)
|
| 586 |
]
|
| 587 |
];
|
| 588 |
|
| 589 |
located_ident: [ [ a = ident_or_keyword -> (lop _loc,ident a) ] ];
|
| 590 |
|
| 591 |
pat: [
|
| 592 |
[ x = pat; "where";
|
| 593 |
b = LIST1 [ (la,a) = located_ident; "="; y = pat ->
|
| 594 |
(la,a,y) ] SEP "and"
|
| 595 |
-> mk _loc (Recurs (x,b)) ]
|
| 596 |
| RIGHTA [ x = pat; "->"; y = pat -> mk _loc (Arrow (x,y))
|
| 597 |
| x = pat; "@"; y = pat -> mk _loc (Concat (x,y))
|
| 598 |
| x = pat; "+"; y = pat -> mk _loc (Merge (x,y)) ]
|
| 599 |
| "no_arrow" [ x = pat; "|"; y = pat -> mk _loc (Or (x,y)) ]
|
| 600 |
| "simple" [ x = pat; "&"; y = pat -> mk _loc (And (x,y))
|
| 601 |
| x = pat; "\\"; y = pat -> mk _loc (Diff (x,y)) ]
|
| 602 |
|
|
| 603 |
[ "{"; r = record_spec; "}" -> r
|
| 604 |
| "ref"; p = pat ->
|
| 605 |
let get_fun = mk _loc (Arrow (pat_nil, p))
|
| 606 |
and set_fun = mk _loc (Arrow (p, pat_nil))in
|
| 607 |
let fields =
|
| 608 |
[ label "get", (get_fun, None); label "set", (set_fun, None) ] in
|
| 609 |
mk _loc (Record (false, fields))
|
| 610 |
| "_" -> mk _loc (Internal Types.any)
|
| 611 |
| "("; a = IDENT; ":="; c = expr; ")" ->
|
| 612 |
mk _loc (Constant (ident a,c))
|
| 613 |
| "!"; a = IDENT ->
|
| 614 |
mk _loc (Internal (Types.abstract (Types.Abstract.atom a)))
|
| 615 |
| ids = LIST1 ident_or_keyword SEP "." ->
|
| 616 |
let ids = List.map (fun x -> ident x) ids in
|
| 617 |
mk _loc (PatVar ids)
|
| 618 |
| i = INT ; "--"; j = INT ->
|
| 619 |
let i = Intervals.V.mk i
|
| 620 |
and j = Intervals.V.mk j in
|
| 621 |
mk _loc (Internal (Types.interval (Intervals.bounded i j)))
|
| 622 |
| i = INT ->
|
| 623 |
let i = Intervals.V.mk i in
|
| 624 |
mk _loc (Internal (Types.interval (Intervals.atom i)))
|
| 625 |
| "*"; "--"; j = INT ->
|
| 626 |
let j = Intervals.V.mk j in
|
| 627 |
mk _loc (Internal (Types.interval (Intervals.left j)))
|
| 628 |
| i = INT; "--"; "*" ->
|
| 629 |
let i = Intervals.V.mk i in
|
| 630 |
mk _loc (Internal (Types.interval (Intervals.right i)))
|
| 631 |
| i = char ->
|
| 632 |
mk _loc (Internal (Types.char (Chars.char_class i i)))
|
| 633 |
| i = char ; "--"; j = char ->
|
| 634 |
mk _loc (Internal (Types.char (Chars.char_class i j)))
|
| 635 |
| "`"; c = tag_type -> c
|
| 636 |
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
|
| 637 |
| "["; r = [ r = regexp -> r | -> Epsilon ];
|
| 638 |
q = [ ";"; q = pat -> Some q
|
| 639 |
| -> None ];
|
| 640 |
"]" ->
|
| 641 |
let r = match q with
|
| 642 |
| Some q ->
|
| 643 |
let any = mk _loc (Internal (Types.any)) in
|
| 644 |
Seq(r,Seq(Guard q, Star (Elem any)))
|
| 645 |
| None -> r
|
| 646 |
in
|
| 647 |
mk _loc (Regexp r)
|
| 648 |
| "<"; t =
|
| 649 |
[ x = tag_type -> x
|
| 650 |
| "("; t = pat; ")" -> t ];
|
| 651 |
a = attrib_spec; ">"; c = pat ->
|
| 652 |
mk _loc (XmlT (t, multi_prod _loc [a;c]))
|
| 653 |
| s = STRING2 ->
|
| 654 |
let s =
|
| 655 |
List.map
|
| 656 |
(fun c ->
|
| 657 |
mknoloc (Internal
|
| 658 |
(Types.char
|
| 659 |
(Chars.atom
|
| 660 |
(Chars.V.mk_int c)))))
|
| 661 |
(seq_of_string s) in
|
| 662 |
let s = s @ [mknoloc (Internal (Sequence.nil_type))] in
|
| 663 |
multi_prod _loc s
|
| 664 |
]
|
| 665 |
|
| 666 |
];
|
| 667 |
|
| 668 |
or_else : [ [ OPT [ "else"; y = pat -> y ] ] ];
|
| 669 |
|
| 670 |
opt_field_pat: [ [ OPT [ "=";
|
| 671 |
o = [ "?" -> true | -> false];
|
| 672 |
x = pat; y = or_else -> (o,x,y) ] ] ];
|
| 673 |
|
| 674 |
record_spec:
|
| 675 |
[ [ r = LIST0 [ l = ident_or_keyword; f = opt_field_pat; OPT ";" ->
|
| 676 |
let (o,x,y) =
|
| 677 |
match f with
|
| 678 |
| None -> (false, mknoloc (PatVar [ident l]), None)
|
| 679 |
| Some z -> z
|
| 680 |
in
|
| 681 |
let x = if o then mk _loc (Optional x) else x in
|
| 682 |
(label l, (x,y))
|
| 683 |
]; op = [ ".." -> true | -> false ] ->
|
| 684 |
mk _loc (Record (op,r))
|
| 685 |
] ];
|
| 686 |
|
| 687 |
char:
|
| 688 |
[
|
| 689 |
[ c = STRING1 -> Chars.V.mk_int (parse_char _loc c) ]
|
| 690 |
];
|
| 691 |
|
| 692 |
|
| 693 |
attrib_spec: [
|
| 694 |
[ r = record_spec -> r
|
| 695 |
| "("; t = pat; ")" -> t
|
| 696 |
] ];
|
| 697 |
|
| 698 |
opt_field_expr: [ [ OPT [ "="; x = expr LEVEL "no_appl" -> x ] ] ];
|
| 699 |
|
| 700 |
expr_record_spec:
|
| 701 |
[ [ r = LIST0
|
| 702 |
[ l = ident_or_keyword;
|
| 703 |
x = opt_field_expr; OPT ";" ->
|
| 704 |
let x = match x with Some x -> x | None -> Var (ident l) in
|
| 705 |
(label l,x) ]
|
| 706 |
->
|
| 707 |
exp _loc (RecordLitt r)
|
| 708 |
] ];
|
| 709 |
|
| 710 |
expr_attrib_spec: [
|
| 711 |
[ e = expr_record_spec -> e
|
| 712 |
| "("; e = expr; ")" -> e
|
| 713 |
] ];
|
| 714 |
END
|
| 715 |
|
| 716 |
module Hook = struct
|
| 717 |
let expr = expr
|
| 718 |
let pat = pat
|
| 719 |
let keyword = keyword
|
| 720 |
end
|
| 721 |
|
| 722 |
let pat = Gram.parse pat Ulexer.Loc.ghost
|
| 723 |
and expr = Gram.parse expr Ulexer.Loc.ghost
|
| 724 |
and prog = Gram.parse prog Ulexer.Loc.ghost
|
| 725 |
and top_phrases = Gram.parse top_phrases Ulexer.Loc.ghost
|
| 726 |
|
| 727 |
let sync () =
|
| 728 |
match !Ulexer.lexbuf with
|
| 729 |
| None -> ()
|
| 730 |
| Some lb ->
|
| 731 |
Ulexer.sync lb
|
| 732 |
|
| 733 |
let sync () =
|
| 734 |
try sync ()
|
| 735 |
with Ulexing.Error -> ()
|
Parent Directory
| 
Revision Log