viewcvs.cgi/parser/parser.ml

#load "pa_extend.cmo";;

open Location
open Ast
open Ident
open Printf

(*
let ()  = Grammar.error_verbose := true
*)

exception Error of string
let error (i,j) s = Location.raise_loc i j (Error s)

let gram    = Grammar.gcreate Ulexer.lex

let parse_ident = U.mk

let id_dummy = ident (U.mk "$$$")

let label = parse_ident
let ident s = ident (parse_ident s)

let prog    = Grammar.Entry.create gram "prog"
let top_phrases   = Grammar.Entry.create gram "toplevel phrases"
let expr    = Grammar.Entry.create gram "expression"
let pat     = Grammar.Entry.create gram "type/pattern expression"
let regexp  = Grammar.Entry.create gram "type/pattern regexp"
let keyword = Grammar.Entry.create gram "keyword"
                
let exp pos e = LocatedExpr (loc_of_pos pos,e)

let rec multi_prod loc = function
  | [ x ] -> x
  | x :: l -> mk loc (Prod (x, multi_prod loc l))
  | [] -> assert false
      
let rec tuple = function
  | [ x ] -> x
  | x :: l -> Pair (x, tuple l)
  | [] -> assert false

let tuple_queue = 
  List.fold_right (fun x q -> Pair (x, q))


let char = mknoloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
               
let seq_of_string s =
  let s = Encodings.Utf8.mk s in
  let rec aux i j =
    if Encodings.Utf8.equal_index i j then []
    else let (c,i) = Encodings.Utf8.next s i in c :: (aux i j)
  in
  aux (Encodings.Utf8.start_index s) (Encodings.Utf8.end_index s)


let parse_char loc s =
  match seq_of_string s with
    | [ c ] -> c
    | _ -> error loc "Character litteral must have length 1"

let include_stack = ref []

let protect_exn f g =
  try let x = f () in g (); x
  with e -> g (); raise e

let localize_exn f = 
  try f ()
  with
  | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
  | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
  

let is_fun_decl =
   Grammar.Entry.of_parser gram "[is_fun_decl]"
     (fun strm ->
       match Stream.npeek 3 strm with
         | [ ("", "fun"); ("IDENT", _); ("", "(") ]
         | [ ("IDENT", _) ; ("", "(") ; _ ] -> ()
         | _ -> raise Stream.Failure
     )

let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
 
let logical_and e1 e2 = if_then_else e1 e2 cst_false
let logical_or e1 e2 = if_then_else e1 cst_true e2
let logical_not e = if_then_else e cst_false cst_true
 

EXTEND
  GLOBAL: top_phrases prog expr pat regexp keyword;

  top_phrases: [
    [ l = LIST0 phrase; ";;" -> List.flatten l  ]
  ];

  prog: [
    [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
  ];

  phrase: [
    [ (f,p,e) = let_binding -> 
        if f then [ mk loc (FunDecl e) ] else
          [ mk loc (LetDecl (p,e)) ]
    | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
        [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
    | "type"; x = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ]
    | "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
        [ mk loc (Using (U.mk name, U.mk cu)) ]
    | "schema"; name = IDENT; "="; uri = STRING2 ->
        protect_op "schema";
        let schema = match Url.process uri with 
                       | Url.Filename s -> Schema_parser.schema_of_file s 
                       | Url.Url s ->  Schema_parser.schema_of_string s in
        [ mk loc (SchemaDecl (U.mk name, schema)) ]
    | (name,ns) = namespace_binding ->
        [ mk loc (Namespace (name, ns)) ]
    | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
        let e = exp loc (NamespaceIn (name, ns, e2)) in
        [ mk loc (EvalStatement (exp loc e)) ]
    | "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
    | DIRECTIVE "#utf8" -> Ulexer.enc := Ulexing.Utf8; [ ]
    | DIRECTIVE "#latin1" -> Ulexer.enc := Ulexing.Latin1; [ ]
    | DIRECTIVE "#ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
    | DIRECTIVE "#quit" -> [ mk loc (Directive `Quit) ]
    | DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
    | DIRECTIVE "#print_schema"; name = IDENT ->
        [ mk loc (Directive (`Print_schema (U.mk name))) ]
    | DIRECTIVE "#print_type"; name = IDENT;
      schema_part = OPT [
        "#"; typ = [ IDENT | keyword ];
        kind = OPT [ "as"; k = schema_kind -> k] ->
          (kind, typ)
      ] ->
        (match schema_part with
        | None -> [ mk loc (Directive (`Print_type (U.mk name))) ]
        | Some (kind, typ) ->
            [ mk loc
              (Directive (`Print_schema_type (kind, U.mk name, U.mk typ))) ])
    | DIRECTIVE "#dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
    | DIRECTIVE "#reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
    | DIRECTIVE "#help" -> [ mk loc (Directive `Help) ]
    | "include"; s = STRING2 ->
        let s = 
          if Filename.is_relative s 
          then Filename.concat (Location.current_dir ()) s
          else s in
        protect_op "File inclusion";
        (* avoid looping; should issue an error ? *)
        (* it is possible to have looping with x/../x/../x/.. ....
           Need to canonicalize filename *)
        if List.mem s !include_stack then [] 
        else (
          include_stack := s :: !include_stack;
          Location.push_source (`File s);
          let saved_enc = !Ulexer.enc in
          Ulexer.enc := Ulexing.Latin1;
          protect_exn
            (fun () ->
               let chan = open_in s in
               protect_exn
                 (fun () ->
                    let input = Stream.of_channel chan in
                    localize_exn (fun () -> Grammar.Entry.parse prog input))
                 (fun () -> close_in chan))
            (fun () ->
               Ulexer.enc := saved_enc;
               Location.pop_source ();
               include_stack := List.tl !include_stack)
        )
    ] | 
    [ e = expr -> [ mk loc (EvalStatement e) ]
    ]
  ];

  debug_directive: [
    [ IDENT "filter"; t = pat; p = pat -> `Filter(t,p)
    | IDENT "accept"; p = pat -> `Accept p
    | IDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
    | IDENT "sample"; t = pat -> `Sample t
    | IDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
    | IDENT "explain"; t = pat; e = expr -> `Explain (t,e)
    ]
  ];

  keyword: [
    [ a = 
        [ "map" | "match" | "with" | "try" | "xtransform"
        | "if" | "then" | "else"
        | "transform" | "fun" | "in"
        | "let" | "type" | "debug" | "include"
        | "and" | "validate" | "schema" | "namespace" | "ref" | "alias"
        | "not" | "as" | "where" | "external"
        ]
        -> a
    ]
  ];

  expr: [
    "top" RIGHTA
    [ "match"; e = SELF; "with"; b = branches -> 
        exp loc (Match (e,b))
    | "try"; e = SELF; "with"; b = branches -> 
        exp loc (Try (e,b))
    | "map"; e = SELF; "with"; b = branches -> 
        exp loc (Map (e,b))
    | "xtransform"; e = SELF; "with"; b = branches -> 
        exp loc (Xtrans (e,b))
    | "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
        exp loc (if_then_else e e1 e2)
    | "transform"; e = SELF; "with"; b = branches -> 
        exp loc (Transform (e,b))
    | "validate"; e = SELF; "with"; (kind, schema, typ) = schema_ref ->
        exp loc (Validate (e, kind, schema, typ))
    | "fun"; (f,a,b) = fun_decl ->
        exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
    | "external"; s = STRING2 ->
        let (t,i) = Externals.parse s in
        exp loc (External (t,i))
    | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
        exp loc (Match (e1,[p,e2]))
    | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
        exp loc (NamespaceIn (name, ns, e2))
    | e = expr; ":"; p = pat ->
        exp loc (Forget (e,p))
    | e1 = expr; ";"; e2 = expr ->
        exp loc (Match (e1, [pat_nil,e2]))
    | "ref"; p = pat; e = expr ->
        exp loc (Ref (e,p))
    | "not"; e = expr -> exp loc (logical_not e)
    ]
    |
    [ e1 = expr; ":="; e2 = expr ->
        exp loc (Apply (Dot (e1, U.mk "set"), e2))
    ]
    | 
    [ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr -> 
        let op = match op with
          | "<<" -> "<"
          | ">>" -> ">"
          | s -> s in
        exp loc (Op (op,[e1;e2]))
    ]

    | 
    [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> 
        exp loc (Op (op,[e1;e2]))
    | e1 = expr; "||"; e2 = expr -> exp loc (logical_or e1 e2)
    | e = expr; "\\"; l = [IDENT | keyword ] -> 
        exp loc (RemoveField (e, label l)) 
    ]
    |
    [ e1 = expr; op = ["*"]; e2 = expr -> exp loc (Op (op,[e1;e2]))  
    | e1 = expr; "&&"; e2 = expr -> exp loc (logical_and e1 e2)
    | e = expr; op = "/"; p = pat LEVEL "simple" ->
        let tag = mk loc (Internal (Types.atom (Atoms.any))) in
        let att = mk loc (Internal Types.Record.any) in
        let any = mk loc (Internal (Types.any)) in
        let re = Star(Alt(SeqCapture(id_dummy,Elem p), Elem any)) in
        let ct = mk loc (Regexp (re,any)) in
        let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
        let b = (p,  Var (Id.value id_dummy)) in
        exp loc (Transform (e,[b]))
    ]
    |
    [ e = expr;  "."; l = [IDENT | keyword ] -> 
        exp loc (Dot (e, label l)) 
    ]  
    |
    [ op = [ IDENT "flatten"
           | IDENT "load_xml"
           | IDENT "load_file" | IDENT "load_file_utf8"
           | IDENT "float_of"
           | IDENT "getenv" | IDENT "argv"
           | IDENT "load_html"
           | IDENT "print_xml" | IDENT "print_xml_utf8"
           | IDENT "print"
           | IDENT "int_of"
           | IDENT "string_of"
           | IDENT "atom_of"
           | IDENT "raise"
           ]; 
      e = expr -> exp loc (Op (op,[e]))
    | op = [ IDENT "dump_to_file" | IDENT "dump_to_file_utf8" ];
      e1 = expr LEVEL "no_appl"; e2 = expr -> exp loc (Op (op, [e1;e2])) 
    | e1 = SELF; IDENT "div"; e2 = expr -> exp loc (Op ("/", [e1;e2]))
    | e1 = SELF; IDENT "mod"; e2 = expr -> exp loc (Op ("mod", [e1;e2]))
    | e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
    ]

    | "no_appl" 
    [ 
      "("; l = LIST1 expr SEP ","; ")" -> exp loc (tuple l)
    | "[";  l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; 
      loc_end = ["]" -> loc] ->
        let e = match e with Some e -> e | None -> cst_nil in
        let e = exp loc_end e in
        let (_,loc_end) = loc_end in
        let l = List.fold_right 
                  (fun x q ->
                     match x with
                       | `String (loc,i,j,s) -> exp loc (String (i,j,s,q))
                       | `Elems ((loc,_),x) -> exp (loc,loc_end) (Pair(x,q))
                       | `Explode x -> Op ("@",[x;q])
                  ) l e
        in
        exp loc l
    | "<"; t = [ "("; e = expr; ")" -> e
               | a = tag -> exp loc a
               ];
        a = expr_attrib_spec; ">"; c = expr ->
          exp loc (Xml (t, Pair (a,c)))
    | "{"; r = [ expr_record_spec | -> exp loc (RecordLitt []) ]; "}" -> r
    | s = STRING2 ->
        let s = U.mk s in
        exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
    | a = IDENT -> exp loc (Var (U.mk a))
    | "!"; e = expr ->
        exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
    | i = INT -> exp loc (Integer (Intervals.V.mk i))
    | "`"; a = tag -> a
    | c = char -> exp loc (Char c)
    ]

  ];

  tag: [ [ a = [ IDENT | keyword ] -> exp loc (Atom (parse_ident a)) ] ];

  tag_type: [
    [ IDENT "_" ->  mk loc (Internal (Types.atom Atoms.any))
    | a = [ IDENT | keyword ] -> mk loc (Cst (Atom (parse_ident a)))
    | t = ANY_IN_NS -> mk loc (NsT (parse_ident t)) 
    ]
  ];

  seq_elem: [
    [ x = STRING1 -> 
        let s = U.mk x in
        `String (loc, U.start_index s, U.end_index s, s)
    | e = expr LEVEL "no_appl" -> `Elems (loc,e)
    | "!"; e = expr LEVEL "no_appl" -> `Explode e
    ]
  ];
        
  namespace_binding: [
    [ "namespace"; 
        name = [ name = [ IDENT | keyword ]; "=" ->
                   parse_ident name
               | -> U.mk "" ];
        uri = STRING2 ->
          let ns = Ns.mk (parse_ident uri) in
          (name,ns)
    ]
  ];

  
  let_binding: [
    [ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
        let f = match f with Some x -> x | None -> assert false in
        let p = mk loc (PatVar (Id.value f)) in
        let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
        let e = exp loc (Abstraction abst) in
        (true,p,e)
    | "let"; p = pat; "="; e = expr -> (false,p,e)
    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
    ] 
  ];

 fun_decl_after_lparen: [
(* need an hack to do this, because both productions would
   match   [ OPT IDENT; "("; pat ] .... *)
   [ p1 = pat LEVEL "no_arrow";
     res = [ "->"; p2 = pat;
             a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
             ")"; b = branches -> `Classic (p2,a,b)
           | ":"; targ1 = pat;
             args = LIST0 [ ","; arg = pat; ":"; targ = pat -> (arg,targ) ]; 
             ")";
             others = LIST0 
                        [ "(";
                          args = 
                            LIST1 
                              [ arg = pat; ":"; targ = pat -> (arg,targ) ]
                              SEP ",";
                          ")" -> args ];
             ":"; tres = pat ; 
             "="; body = expr ->
               `Compact (targ1,args,others,tres,body)
           ] ->
       match res with
         | `Classic (p2,a,b) -> (p1,p2)::a,b
         | `Compact (targ1,args,others,tres,body) ->
             let mkfun args =
               multi_prod nopos (List.map snd args),
               multi_prod nopos (List.map fst args)
             in
             let (tres,body) =
               List.fold_right
                 (fun args (tres,body) ->
                    let (targ,arg) = mkfun args in
                    let e = Abstraction 
                              { fun_name = None; fun_iface = [targ,tres]; 
                                fun_body = [arg,body] } in
                    let t = mknoloc (Arrow (targ,tres)) in
                    (t,e)
                 )
                 others (tres,body) in
             let (targ,arg) = mkfun ((p1,targ1) :: args) in
             [(targ,tres)],[(arg,body)]
              ] ];


 fun_decl: [
   [ f = OPT IDENT; "("; (a,b) = fun_decl_after_lparen ->
       let f = match f with Some x -> Some (ident x) | None -> None in
       (f,a,b)
   ]
 ];

 arrow: [
    [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
  ];

  branches: [
    [ OPT "|"; l = LIST1 branch SEP "|" -> l ]
  ];

  branch: [
    [ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
  ];

          
  regexp: [ 
    [ x = regexp; "|"; y = regexp -> 
        match (x,y) with
          | Elem x, Elem y -> Elem (mk loc (Or (x,y)))
          | _ -> Alt (x,y) 
    ]
  | [ x = regexp; y = regexp -> Seq (x,y) ]
  | [ x = regexp; "&"; y = regexp ->
        match (x,y) with
          | Elem x, Elem y -> Elem (mk loc (And (x,y)))
          | _ -> error loc "Conjunction not allowed in regular expression"
    ]
  | [ a = IDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
  | [ x = regexp; "*" -> Star x
    | x = regexp; "*?" -> WeakStar x
    | x = regexp; "+" -> Seq (x, Star x)
    | x = regexp; "+?" -> Seq (x, WeakStar x)
    | x = regexp; "?" ->  Alt (x, Epsilon)
    | x = regexp; "??" -> Alt (Epsilon, x) ]
  | [ "("; x = LIST1 regexp SEP ","; ")" ->
        (match x with
          | [ x ] -> x
          | _ ->
              let x = 
                List.map 
                  (function
                     | Elem x -> x
                     | _ -> error loc 
                         "Mixing regular expressions and products")
                  x in
              Elem (multi_prod loc x))
    | "("; a = IDENT; ":="; c = expr; ")" -> 
        Elem (mk loc (Constant ((ident a,c))))
    | IDENT "PCDATA" -> string_regexp
    | i = STRING1; "--"; j = STRING1 ->
        let i = Chars.V.mk_int (parse_char loc i)
        and j = Chars.V.mk_int (parse_char loc j) in
        Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
    |  s = STRING1 ->
        List.fold_right
          (fun c accu -> 
             let c = Chars.V.mk_int c in
             let c = Chars.atom c in
             Seq (Elem (mknoloc (Internal (Types.char c))), accu))
          (seq_of_string s)
          Epsilon ]
    | [ e = pat LEVEL "simple" -> Elem e
    ]
  ];

  schema_kind : [
    [ IDENT "element" -> `Element
    | "type" -> `Type
    | IDENT "attribute" -> `Attribute
    | IDENT "attribute_group" -> `Attribute_group
    | IDENT "model_group" -> `Model_group
    ]
  ];

  schema_ref: [
    [ schema = IDENT; "#"; typ = [ IDENT | keyword ];
      kind = OPT [ "as"; k = schema_kind -> k] ->
        (kind, U.mk schema, U.mk typ)
    ]
  ];

  pat: [ 
      [ x = pat; "where"; 
        b = LIST1 [ a = IDENT; "="; y = pat -> (ident a,y) ] SEP "and"
            -> mk loc (Recurs (x,b)) ]
    | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
    | "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ] 
    | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y)) 
               | x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
    | 
      [ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
      | "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
      | "ref"; p = pat ->
          let get_fun = mk loc (Arrow (pat_nil, p)) 
          and set_fun = mk loc (Arrow (p, pat_nil)) in
          let fields = [ label "get", get_fun; label "set", set_fun ] in
          mk loc (Record (false, fields))
      | IDENT "_" -> mk loc (Internal Types.any)
      | "("; a = IDENT; ":="; c = expr; ")" -> 
          mk loc (Constant (ident a,c))
      | schema = IDENT; "#"; typ = [ IDENT | keyword ];
        kind = OPT [ "as"; k = schema_kind -> k] ->
          mk loc (SchemaVar (kind, U.mk schema, U.mk typ))
      | "!"; a = IDENT ->
          mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
      | a = IDENT -> 
          mk loc (PatVar (U.mk a))
      | i = INT ; "--"; j = INT -> 
          let i =  Intervals.V.mk i 
          and j =  Intervals.V.mk j in
          mk loc (Internal (Types.interval (Intervals.bounded i j)))
      | i = INT -> 
          let i =  Intervals.V.mk i  in
          mk loc (Internal (Types.interval (Intervals.atom i)))
      | "*"; "--"; j = INT ->
          let j =  Intervals.V.mk j in
          mk loc (Internal (Types.interval (Intervals.left j)))
      | i = INT; "--"; "*" ->
          let i = Intervals.V.mk i in
          mk loc (Internal (Types.interval (Intervals.right i)))
      | i = char ->
          mk loc (Internal (Types.char (Chars.char_class i i)))
      | i = char ; "--"; j = char ->
          mk loc (Internal (Types.char (Chars.char_class i j)))
      | "`"; c = tag_type -> c
      | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
      | "["; r = [ r = regexp -> r | -> Epsilon ];
             q = [ ";"; q = pat -> q 
                 | -> pat_nil ]; 
             "]" -> mk loc (Regexp (r,q))
      | "<"; t =
            [ x = tag_type -> x
            | "("; t = pat; ")" -> t ];
        a = attrib_spec; ">"; c = pat ->
          mk loc (XmlT (t, multi_prod loc [a;c]))
      | s = STRING2 ->
          let s = 
            List.map 
              (fun c -> 
                 mknoloc (Internal
                             (Types.char
                                (Chars.atom
                                   (Chars.V.mk_int c))))) 
              (seq_of_string s) in
          let s = s @ [mknoloc (Internal (Sequence.nil_type))] in
          multi_prod loc s
      ]
    
  ];

  record_spec:
    [ [ r = LIST0 [ l = [IDENT | keyword ]; "=";
                  o = [ "?" -> true | -> false]; 
                  x = pat -> 
                    let x = if o then mk loc (Optional x) else x in
                    (label l, x)
                ] SEP ";" ->
          r
      ] ];
  
  char:
    [ 
      [ c = STRING1 -> Chars.V.mk_int (parse_char loc c) ]
    ];
     

  attrib_spec:
    [ [ r = LIST0 [ l = [IDENT | keyword ]; "=";
                  o = [ "?" -> true | -> false]; 
                  x = pat; OPT ";" -> 
                    let x = if o then mk loc (Optional x) else x in
                    (label l, x)
                ] ->
          mk loc (Record (true,r)) 
      | "("; t = pat; ")" -> t 
      | "{"; r = record_spec; "}" -> mk loc (Record (true,r))
      | "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
      ] ];

  expr_record_spec:
    [ [ r = LIST1
              [ l = [IDENT | keyword ]; "="; x = expr LEVEL "no_appl" -> 
                  (label l,x) ] 
               SEP ";"  ->
          exp loc (RecordLitt r)
      ] ];

  expr_attrib_spec:
    [ [ r = LIST1
              [ l = [IDENT | keyword ]; "="; x = expr LEVEL "no_appl"; OPT ";" -> 
                  (label l,x) ] ->
          exp loc (RecordLitt r)
      ]
    | [ e = expr LEVEL "no_appl" -> e 
      | -> exp loc (RecordLitt []) 
      ] 
    ];
END

module Hook = struct
  let expr = expr
  let pat = pat
  let keyword = keyword
end

let pat = Grammar.Entry.parse pat
and expr = Grammar.Entry.parse expr
and prog = Grammar.Entry.parse prog
and top_phrases = Grammar.Entry.parse top_phrases

let sync () = 
  match !Ulexer.lexbuf with
    | None -> ()
    | Some lb ->
        let rec aux () =
          match !Ulexer.last_tok with
            | ("",";;") | ("EOI","") -> ()
            | _ -> 
                Ulexer.last_tok := fst (Ulexer.token lb); 
                aux ()
        in
        aux ()

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