viewcvs.cgi/parser/parser.ml

open Location
open Ast
open Ident

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

let gram    = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)


let prog    = Grammar.Entry.create gram "prog"
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 const   = Grammar.Entry.create gram "scalar constant"
                
let rec multi_prod loc = function
  | [ x ] -> x
  | x :: l -> mk loc (Prod (x, multi_prod loc l))
  | [] -> assert false
      
let rec tuple loc = function
  | [ x ] -> x
  | x :: l -> mk loc (Pair (x, tuple loc l))
  | [] -> assert false

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


let char = mk noloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
               
let cst_nil =  mk noloc (Cst (Types.Atom Sequence.nil_atom))
                 
let seq_of_string pos s =
  let (pos,_) = pos in
  let rec aux accu i = 
    if (i = 0) 
    then accu 
    else aux (((pos+i,pos+i+1),s.[i-1])::accu) (i-1) in
  aux [] (String.length s)

exception Error of string
let error loc s = raise (Location (loc, Error s))

let make_record loc r =
  LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r

let parse_char loc s =
  (* TODO: Unicode *)
  if String.length s <> 1 then
    error loc "Character litteral must have length 1";
  s.[0]

let char_list pos s = 
  let s = seq_of_string pos s in
  List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.mk_char c)))) s


EXTEND
  GLOBAL: prog expr pat regexp const;

  prog: [
    [ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; EOI -> l ]
  ];

  phrase: [
    [ (p,e) = let_binding -> LetDecl (p,e)
    | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
        EvalStatement (mk loc (Match (e1,[p,e2])))
    | LIDENT "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
    | LIDENT "debug"; d = debug_directive -> Debug d
    ] | 
    [ e = expr -> EvalStatement e 
    ]
  ];

  debug_directive: [
    [ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
    | LIDENT "accept"; p = pat -> `Accept p
    | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
    | LIDENT "normal_record"; t = pat -> `Normal_record t
    | LIDENT "compile2"; t = pat; p = LIST1 pat -> `Compile2 (t,p)
    | LIDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
    ]
  ];

  expr: [
    "top" RIGHTA
    [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
    | "try"; e = SELF; "with"; b = branches -> 
        let default = 
          (mk noloc (Capture (ident "x")),
           mk noloc (Op ("raise",[mk noloc (Var (ident "x"))]))) in
        mk loc (Try (e,b@[default]))
    | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
    | "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
        let p1 = mk loc (Internal (Builtin.true_type))
        and p2 = mk loc (Internal (Builtin.false_type)) in
        mk loc (Match (e, [p1,e1; p2,e2]))
    | "transform"; e = SELF; "with"; b = branches -> 
        let default = mk noloc (Capture (ident "x")), cst_nil in
        mk loc (Op ("flatten", [mk loc (Map (e,b@[default]))]))
    | "fun"; (f,a,b) = fun_decl ->
        mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
    | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
        mk loc (Match (e1,[p,e2]))
    | e = expr; ":"; p = pat ->
        mk loc (Forget (e,p))
    ]

    
    | 
    [ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr -> 
        let op = match op with
          | "<<" -> "<"
          | ">>" -> ">"
          | s -> s in
        mk loc (Op (op,[e1;e2]))
    ]

    | 
    [ e1 = expr; op = ["+" | "-" | "@" | "++"]; e2 = expr -> 
        mk loc (Op (op,[e1;e2]))
    | e = expr; "--"; l = [LIDENT | UIDENT] -> 
        mk loc (RemoveField (e,LabelPool.mk l)) 
    ]
    |
    [ e1 = expr; op = ["*"]; e2 = expr -> mk loc (Op (op,[e1;e2]))  
    | e = expr; op = "/"; p = pat ->

        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(ident "x",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,  mk loc (Var (ident "x"))) in
        mk loc (Op ("flatten", [mk loc (Map (e,[b]))]))
    ]
    |
    [ e = expr;  "."; l = [LIDENT | UIDENT] -> 
        mk loc (Dot (e,LabelPool.mk l)) 
    ]  
 
    |
    [ op = [ LIDENT "flatten"
           | LIDENT "load_xml"
           | LIDENT "load_html"
           | LIDENT "print_xml"
           | LIDENT "print"
           | LIDENT "raise" 
           | LIDENT "int_of"
           | LIDENT "string_of"
           ]; 
      e = expr -> mk loc (Op (op,[e]))
    | op = [ LIDENT "dump_to_file" ];
      e1 = expr LEVEL "no_appl"; e2 = expr -> mk loc (Op (op, [e1;e2])) 
    | e1 = SELF; LIDENT "div"; e2 = expr -> mk loc (Op ("/", [e1;e2]))
    | e1 = SELF; LIDENT "mod"; e2 = expr -> mk loc (Op ("mod", [e1;e2]))
    | e1 = SELF; e2 = expr -> mk loc (Apply (e1,e2))
    ]

    | "no_appl" 
    [ c = const -> mk loc (Cst c)
    | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
    | "[";  l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; "]" ->
        let e = match e with Some e -> e | None -> cst_nil in
        List.fold_right 
          (fun x q ->
             match x with
               | `Elems l -> tuple_queue l q
               | `Explode x -> mk x.loc (Op ("@",[x;q]))
          ) l e
    | t = [ a = TAG -> 
              mk loc (Cst (Types.Atom (Atoms.mk a)))
          | "<"; e = expr LEVEL "no_appl" -> e ];
        a = expr_attrib_spec; ">"; c = expr ->
        mk loc (Xml (t, mk loc (Pair (a,c))))
    | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt LabelMap.empty) ]; "}" -> r
    | s = STRING2 ->
        tuple loc (char_list loc s @ [cst_nil])
    | a = LIDENT -> mk loc (Var (ident a))
    ]

  ];

  seq_elem: [
    [ x = STRING1 -> `Elems (char_list loc x)
    | e = expr LEVEL "no_appl" -> `Elems [e]
    | "!"; e = expr LEVEL "no_appl" -> `Explode e
    ]
  ];
          
  let_binding: [
    [ "let"; p = pat; "="; e = expr -> (p,e)
    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, mk noloc (Forget (e,t)))
    | "let"; "fun"; (f,a,b) = fun_decl ->
        let p = match f with 
          | Some x -> mk loc (Capture x)
          | _ -> failwith "Function name mandatory in let fun declarations"
        in
        let abst = { fun_name = f; fun_iface = a; fun_body = b } in
        let e = mk loc (Abstraction abst) in
        (p,e);
    ] 
  ];

 fun_decl: [
(* need an hack to do this, because both productions would
   match   [ OPT LIDENT; "("; pat ] .... *)
   [ f = OPT [ x = LIDENT -> ident x]; "("; 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) ]; 
            ")"; ":"; tres = pat ; 
            "="; body = expr ->
              `Compact (targ1,args,tres,body)
          ] ->
      match res with
        | `Classic (p2,a,b) -> f,(p1,p2)::a,b
        | `Compact (targ1,args,tres,body) ->
            let args = (p1,targ1) :: args in
            let targ = multi_prod noloc (List.map snd args) in
            let arg = multi_prod noloc (List.map fst args) in
            let b = [arg, body] in
            let a = [targ,tres] 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) ]
  | [ a = LIDENT; "::"; 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 = regexp; ")" -> x
    | "("; a = LIDENT; ":="; c = const; ")" -> 
        Elem (mk loc (Constant ((ident a,c))))
    | UIDENT "PCDATA" -> string_regexp
    | i = STRING1; "--"; j = STRING1 ->
        let i = Chars.mk_char (parse_char loc i)
        and j = Chars.mk_char (parse_char loc j) in
        Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
    |  s = STRING1 ->
        let s = seq_of_string loc s in
        List.fold_right
          (fun (loc,c) accu -> 
             let c = Chars.mk_char c in
             let c = Chars.atom c in
             Seq (Elem (mk loc (Internal (Types.char c))), accu))
          s
          Epsilon 
    | e = pat LEVEL "simple" -> Elem e
    ]
  ];

  pat: [ 
      [ x = pat; "where"; 
        b = LIST1 [ a = UIDENT; "="; y = pat -> (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))
      | LIDENT "_" -> mk loc (Internal Types.any)
      | a = LIDENT -> mk loc (Capture (ident a))
      | "("; a = LIDENT; ":="; c = const; ")" -> 
          mk loc (Constant (ident a,c))
      | a = UIDENT -> mk loc (PatVar a)
      | i = INT ; "--"; j = INT -> 
          let i =  Intervals.mk i 
          and j =  Intervals.mk j in
          mk loc (Internal (Types.interval (Intervals.bounded i j)))
      | i = INT -> 
          let i =  Intervals.mk i  in
          mk loc (Internal (Types.interval (Intervals.atom i)))
      | "*"; "--"; j = INT ->
          let j =  Intervals.mk j in
          mk loc (Internal (Types.interval (Intervals.left j)))
      | i = INT; "--"; "*" ->
          let i = Intervals.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 = const -> mk loc (Internal (Types.constant c))
      | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
      | "["; r = [ r = regexp -> r | -> Epsilon ];
             q = [ ";"; q = pat -> q 
                 | -> mk noloc (Internal (Sequence.nil_type)) ]; 
             "]" -> mk loc (Regexp (r,q))
      | t = [
          [ "<"; LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any)))
          | a = TAG -> 
              mk loc 
              (Internal (Types.atom (Atoms.atom (Atoms.mk a)))) ]
        | [ "<"; t = pat -> t ]
        ];
        a = attrib_spec; ">"; c = pat ->
          mk loc (XmlT (t, multi_prod loc [a;c]))
      | s = STRING2 ->
          let s = seq_of_string loc s in
          let s = List.map 
                    (fun (loc,c) -> 
                       mk loc (Internal
                                 (Types.char
                                    (Chars.atom
                                       (Chars.mk_char c))))) s in
          let s = s @ [mk loc (Internal (Sequence.nil_type))] in
          multi_prod loc s
      ]
    
  ];

  record_spec:
    [ [ r = LIST0 [ l = [LIDENT | UIDENT]; "=";
                  o = [ "?" -> true | -> false]; 
                  x = pat -> 
                    let x = if o then mk loc (Optional x) else x in
                    (LabelPool.mk l, x)
                ] SEP ";" ->
          make_record loc r
      ] ];
  
  char:
    [ 
      [ c = STRING1 -> Chars.mk_char (parse_char loc c)
      | "!"; i = INT -> Chars.mk_int (int_of_string i) ]
    ];
     

  const:
    [ 
      [ i = INT -> Types.Integer (Intervals.mk i)
      | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Atoms.mk a)
      | c = char -> Types.Char c ]
    ];


  attrib_spec:
    [ [ r = record_spec -> mk loc (Record (true,r)) 
      | "("; t = pat; ")" -> t ] ];

  expr_record_spec:
    [ [ r = LIST1
              [ l = [LIDENT | UIDENT]; "="; x = expr -> 
                  (LabelPool.mk l,x) ] 
              SEP ";" ->
          mk loc (RecordLitt (make_record loc r))
      ] ];
  
  expr_attrib_spec:
    [ [ r = expr_record_spec -> r ]
    | [ e = expr LEVEL "no_appl" -> e 
      | -> mk loc (RecordLitt (LabelMap.empty)) 
      ] 
    ];
END

let pat'  = Grammar.Entry.create gram "type/pattern expression"
EXTEND GLOBAL: pat pat';
  pat': [  [ p = pat; EOI -> p ] ];
END

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

module From_string = struct
  let pat s = Grammar.Entry.parse pat' (Stream.of_string s)
  let expr s = expr (Stream.of_string s)
end

1	abate	4	open Location
2			open Ast
3	abate	225	open Ident
4	abate	4
5	abate	161	(*
6	abate	151	let () = Grammar.error_verbose := true
7	abate	161	*)
8	abate	81
9			let gram = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
10
11
12	abate	38	let prog = Grammar.Entry.create gram "prog"
13			let expr = Grammar.Entry.create gram "expression"
14			let pat = Grammar.Entry.create gram "type/pattern expression"
15			let regexp = Grammar.Entry.create gram "type/pattern regexp"
16			let const = Grammar.Entry.create gram "scalar constant"
17
18			let rec multi_prod loc = function
19			\| [ x ] -> x
20			\| x :: l -> mk loc (Prod (x, multi_prod loc l))
21			\| [] -> assert false
22
23			let rec tuple loc = function
24			\| [ x ] -> x
25	abate	91	\| x :: l -> mk loc (Pair (x, tuple loc l))
26	abate	38	\| [] -> assert false
27	abate	89
28			let tuple_queue =
29			List.fold_right (fun x q -> mk x.loc (Pair (x, q)))
30
31	abate	233
32
33	abate	38	let char = mk noloc (Internal (Types.char Chars.any))
34	abate	66	let string_regexp = Star (Elem char)
35	abate	38
36			let cst_nil = mk noloc (Cst (Types.Atom Sequence.nil_atom))
37
38	abate	66	let seq_of_string pos s =
39			let (pos,_) = pos in
40			let rec aux accu i =
41			if (i = 0)
42			then accu
43			else aux (((pos+i,pos+i+1),s.[i-1])::accu) (i-1) in
44	abate	38	aux [] (String.length s)
45	abate	4
46	abate	81	exception Error of string
47			let error loc s = raise (Location (loc, Error s))
48	abate	18
49	abate	233	let make_record loc r =
50			LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r
51
52	abate	81	let parse_char loc s =
53			(* TODO: Unicode *)
54			if String.length s <> 1 then
55			error loc "Character litteral must have length 1";
56			s.[0]
57
58	abate	66	let char_list pos s =
59	abate	81	let s = seq_of_string pos s in
60	abate	222	List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.mk_char c)))) s
61	abate	18
62
63	abate	38	EXTEND
64	abate	10	GLOBAL: prog expr pat regexp const;
65	abate	4
66	abate	10	prog: [
67	abate	14	[ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; EOI -> l ]
68	abate	10	];
69
70	abate	13	phrase: [
71	abate	66	[ (p,e) = let_binding -> LetDecl (p,e)
72			\| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
73			EvalStatement (mk loc (Match (e1,[p,e2])))
74	abate	81	\| LIDENT "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
75			\| LIDENT "debug"; d = debug_directive -> Debug d
76	abate	66	] \|
77			[ e = expr -> EvalStatement e
78	abate	43	]
79	abate	13	];
80
81	abate	43	debug_directive: [
82			[ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
83	abate	75	\| LIDENT "accept"; p = pat -> `Accept p
84	abate	43	\| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
85	abate	75	\| LIDENT "normal_record"; t = pat -> `Normal_record t
86	abate	145	\| LIDENT "compile2"; t = pat; p = LIST1 pat -> `Compile2 (t,p)
87	abate	224	\| LIDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
88	abate	43	]
89			];
90
91	abate	4	expr: [
92			"top" RIGHTA
93			[ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
94	abate	64	\| "try"; e = SELF; "with"; b = branches ->
95			let default =
96	abate	225	(mk noloc (Capture (ident "x")),
97			mk noloc (Op ("raise",[mk noloc (Var (ident "x"))]))) in
98	abate	64	mk loc (Try (e,b@[default]))
99	abate	81	\| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
100	abate	237	\| "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
101			let p1 = mk loc (Internal (Builtin.true_type))
102			and p2 = mk loc (Internal (Builtin.false_type)) in
103			mk loc (Match (e, [p1,e1; p2,e2]))
104	abate	17	\| "transform"; e = SELF; "with"; b = branches ->
105	abate	225	let default = mk noloc (Capture (ident "x")), cst_nil in
106	abate	121	mk loc (Op ("flatten", [mk loc (Map (e,b@[default]))]))
107	abate	48	\| "fun"; (f,a,b) = fun_decl ->
108	abate	4	mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
109			\| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
110			mk loc (Match (e1,[p,e2]))
111	abate	54	\| e = expr; ":"; p = pat ->
112			mk loc (Forget (e,p))
113	abate	4	]
114
115
116	abate	15	\|
117	abate	237	[ e1 = expr; op = ["=" \| "<=" \| "<<" \| ">>" \| ">=" ]; e2 = expr ->
118			let op = match op with
119			\| "<<" -> "<"
120			\| ">>" -> ">"
121			\| s -> s in
122			mk loc (Op (op,[e1;e2]))
123			]
124
125			\|
126	abate	240	[ e1 = expr; op = ["+" \| "-" \| "@" \| "++"]; e2 = expr ->
127			mk loc (Op (op,[e1;e2]))
128			\| e = expr; "--"; l = [LIDENT \| UIDENT] ->
129			mk loc (RemoveField (e,LabelPool.mk l))
130	abate	51	]
131	abate	16	\|
132	abate	151	[ e1 = expr; op = ["*"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
133			\| e = expr; op = "/"; p = pat ->
134
135			let tag = mk loc (Internal (Types.atom (Atoms.any))) in
136			let att = mk loc (Internal Types.Record.any) in
137			let any = mk loc (Internal (Types.any)) in
138	abate	225	let re = Star(Alt(SeqCapture(ident "x",Elem p), Elem any)) in
139	abate	151	let ct = mk loc (Regexp (re,any)) in
140			let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
141	abate	225	let b = (p, mk loc (Var (ident "x"))) in
142	abate	151	mk loc (Op ("flatten", [mk loc (Map (e,[b]))]))
143	abate	51	]
144	abate	26	\|
145	abate	78	[ e = expr; "."; l = [LIDENT \| UIDENT] ->
146	abate	233	mk loc (Dot (e,LabelPool.mk l))
147	abate	51	]
148	abate	26
149	abate	52	\|
150	abate	66	[ op = [ LIDENT "flatten"
151			\| LIDENT "load_xml"
152	abate	188	\| LIDENT "load_html"
153	abate	76	\| LIDENT "print_xml"
154	abate	124	\| LIDENT "print"
155	abate	66	\| LIDENT "raise"
156			\| LIDENT "int_of"
157	abate	133	\| LIDENT "string_of"
158	abate	66	];
159			e = expr -> mk loc (Op (op,[e]))
160	abate	126	\| op = [ LIDENT "dump_to_file" ];
161			e1 = expr LEVEL "no_appl"; e2 = expr -> mk loc (Op (op, [e1;e2]))
162	abate	151	\| e1 = SELF; LIDENT "div"; e2 = expr -> mk loc (Op ("/", [e1;e2]))
163	abate	210	\| e1 = SELF; LIDENT "mod"; e2 = expr -> mk loc (Op ("mod", [e1;e2]))
164	abate	151	\| e1 = SELF; e2 = expr -> mk loc (Apply (e1,e2))
165	abate	52	]
166
167	abate	4	\| "no_appl"
168			[ c = const -> mk loc (Cst c)
169			\| "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
170	abate	18	\| "["; l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; "]" ->
171			let e = match e with Some e -> e \| None -> cst_nil in
172	abate	89	List.fold_right
173			(fun x q ->
174			match x with
175			\| `Elems l -> tuple_queue l q
176			\| `Explode x -> mk x.loc (Op ("@",[x;q]))
177			) l e
178	abate	81	\| t = [ a = TAG ->
179	abate	222	mk loc (Cst (Types.Atom (Atoms.mk a)))
180	abate	81	\| "<"; e = expr LEVEL "no_appl" -> e ];
181			a = expr_attrib_spec; ">"; c = expr ->
182	abate	110	mk loc (Xml (t, mk loc (Pair (a,c))))
183	abate	233	\| "{"; r = [ expr_record_spec \| -> mk loc (RecordLitt LabelMap.empty) ]; "}" -> r
184	abate	81	\| s = STRING2 ->
185	abate	38	tuple loc (char_list loc s @ [cst_nil])
186	abate	225	\| a = LIDENT -> mk loc (Var (ident a))
187	abate	4	]
188
189			];
190	abate	18
191			seq_elem: [
192	abate	89	[ x = STRING1 -> `Elems (char_list loc x)
193			\| e = expr LEVEL "no_appl" -> `Elems [e]
194			\| "!"; e = expr LEVEL "no_appl" -> `Explode e
195	abate	18	]
196			];
197	abate	4
198			let_binding: [
199			[ "let"; p = pat; "="; e = expr -> (p,e)
200	abate	54	\| "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, mk noloc (Forget (e,t)))
201	abate	48	\| "let"; "fun"; (f,a,b) = fun_decl ->
202			let p = match f with
203			\| Some x -> mk loc (Capture x)
204			\| _ -> failwith "Function name mandatory in let fun declarations"
205			in
206			let abst = { fun_name = f; fun_iface = a; fun_body = b } in
207	abate	4	let e = mk loc (Abstraction abst) in
208	abate	48	(p,e);
209	abate	4	]
210			];
211
212	abate	48	fun_decl: [
213	abate	85	(* need an hack to do this, because both productions would
214			match [ OPT LIDENT; "("; pat ] .... *)
215	abate	225	[ f = OPT [ x = LIDENT -> ident x]; "("; p1 = pat LEVEL "no_arrow";
216	abate	85	res = [ "->"; p2 = pat;
217			a = [ ";"; a = LIST0 arrow SEP ";" -> a \| -> [] ];
218			")"; b = branches -> `Classic (p2,a,b)
219			\| ":"; targ1 = pat;
220			args = LIST0 [ ","; arg = pat; ":"; targ = pat -> (arg,targ) ];
221			")"; ":"; tres = pat ;
222			"="; body = expr ->
223			`Compact (targ1,args,tres,body)
224			] ->
225			match res with
226			\| `Classic (p2,a,b) -> f,(p1,p2)::a,b
227			\| `Compact (targ1,args,tres,body) ->
228			let args = (p1,targ1) :: args in
229			let targ = multi_prod noloc (List.map snd args) in
230			let arg = multi_prod noloc (List.map fst args) in
231			let b = [arg, body] in
232			let a = [targ,tres] in
233			(f,a,b)
234	abate	48	]
235			];
236
237	abate	85	arrow: [
238	abate	9	[ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
239	abate	4	];
240
241			branches: [
242	abate	81	[ OPT "\|"; l = LIST1 branch SEP "\|" -> l ]
243	abate	4	];
244
245			branch: [
246	abate	6	[ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
247	abate	4	];
248
249
250			regexp: [
251	abate	236	[ x = regexp; "\|"; y = regexp ->
252			match (x,y) with
253			\| Elem x, Elem y -> Elem (mk loc (Or (x,y)))
254			\| _ -> Alt (x,y)
255			]
256	abate	4	\| [ x = regexp; y = regexp -> Seq (x,y) ]
257	abate	225	\| [ a = LIDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
258	abate	4	\| [ x = regexp; "*" -> Star x
259			\| x = regexp; "*?" -> WeakStar x
260			\| x = regexp; "+" -> Seq (x, Star x)
261			\| x = regexp; "+?" -> Seq (x, WeakStar x)
262	abate	71	\| x = regexp; "?" -> Alt (x, Epsilon)
263	abate	4	\| x = regexp; "??" -> Alt (Epsilon, x) ]
264			\| [ "("; x = regexp; ")" -> x
265	abate	225	\| "("; a = LIDENT; ":="; c = const; ")" ->
266			Elem (mk loc (Constant ((ident a,c))))
267	abate	66	\| UIDENT "PCDATA" -> string_regexp
268	abate	81	\| i = STRING1; "--"; j = STRING1 ->
269	abate	222	let i = Chars.mk_char (parse_char loc i)
270			and j = Chars.mk_char (parse_char loc j) in
271	abate	66	Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
272	abate	81	\| s = STRING1 ->
273			let s = seq_of_string loc s in
274	abate	18	List.fold_right
275	abate	66	(fun (loc,c) accu ->
276	abate	222	let c = Chars.mk_char c in
277	abate	18	let c = Chars.atom c in
278			Seq (Elem (mk loc (Internal (Types.char c))), accu))
279			s
280	abate	66	Epsilon
281	abate	4	\| e = pat LEVEL "simple" -> Elem e
282			]
283			];
284
285			pat: [
286			[ x = pat; "where";
287			b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"
288			-> mk loc (Recurs (x,b)) ]
289			\| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
290	abate	6	\| "no_arrow" [ x = pat; "\|"; y = pat -> mk loc (Or (x,y)) ]
291	abate	121	\| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
292	abate	99	\| x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
293	abate	4	\|
294	abate	159	[ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
295			\| "{\|"; r = record_spec; "\|}" -> mk loc (Record (false,r))
296	abate	4	\| LIDENT "_" -> mk loc (Internal Types.any)
297	abate	225	\| a = LIDENT -> mk loc (Capture (ident a))
298			\| "("; a = LIDENT; ":="; c = const; ")" ->
299			mk loc (Constant (ident a,c))
300	abate	4	\| a = UIDENT -> mk loc (PatVar a)
301			\| i = INT ; "--"; j = INT ->
302	abate	222	let i = Intervals.mk i
303			and j = Intervals.mk j in
304	abate	52	mk loc (Internal (Types.interval (Intervals.bounded i j)))
305			\| i = INT ->
306	abate	222	let i = Intervals.mk i in
307	abate	52	mk loc (Internal (Types.interval (Intervals.atom i)))
308	abate	81	\| "*"; "--"; j = INT ->
309	abate	222	let j = Intervals.mk j in
310	abate	52	mk loc (Internal (Types.interval (Intervals.left j)))
311	abate	81	\| i = INT; "--"; "*" ->
312	abate	222	let i = Intervals.mk i in
313	abate	52	mk loc (Internal (Types.interval (Intervals.right i)))
314	abate	19	\| i = char ->
315			mk loc (Internal (Types.char (Chars.char_class i i)))
316	abate	13	\| i = char ; "--"; j = char ->
317	abate	18	mk loc (Internal (Types.char (Chars.char_class i j)))
318	abate	4	\| c = const -> mk loc (Internal (Types.constant c))
319			\| "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
320			\| "["; r = [ r = regexp -> r \| -> Epsilon ];
321			q = [ ";"; q = pat -> q
322	abate	18	\| -> mk noloc (Internal (Sequence.nil_type)) ];
323	abate	4	"]" -> mk loc (Regexp (r,q))
324	abate	81	\| t = [
325			[ "<"; LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any)))
326			\| a = TAG ->
327			mk loc
328	abate	222	(Internal (Types.atom (Atoms.atom (Atoms.mk a)))) ]
329	abate	81	\| [ "<"; t = pat -> t ]
330			];
331			a = attrib_spec; ">"; c = pat ->
332	abate	110	mk loc (XmlT (t, multi_prod loc [a;c]))
333	abate	81	\| s = STRING2 ->
334			let s = seq_of_string loc s in
335	abate	63	let s = List.map
336	abate	66	(fun (loc,c) ->
337	abate	63	mk loc (Internal
338			(Types.char
339			(Chars.atom
340	abate	222	(Chars.mk_char c))))) s in
341	abate	63	let s = s @ [mk loc (Internal (Sequence.nil_type))] in
342			multi_prod loc s
343	abate	4	]
344
345			];
346
347			record_spec:
348	abate	81	[ [ r = LIST0 [ l = [LIDENT \| UIDENT]; "=";
349			o = [ "?" -> true \| -> false];
350	abate	229	x = pat ->
351			let x = if o then mk loc (Optional x) else x in
352	abate	233	(LabelPool.mk l, x)
353	abate	4	] SEP ";" ->
354	abate	233	make_record loc r
355	abate	4	] ];
356
357	abate	13	char:
358			[
359	abate	222	[ c = STRING1 -> Chars.mk_char (parse_char loc c)
360			\| "!"; i = INT -> Chars.mk_int (int_of_string i) ]
361	abate	13	];
362
363
364	abate	4	const:
365			[
366	abate	222	[ i = INT -> Types.Integer (Intervals.mk i)
367			\| "`"; a = [LIDENT \| UIDENT] -> Types.Atom (Atoms.mk a)
368	abate	13	\| c = char -> Types.Char c ]
369	abate	4	];
370
371
372			attrib_spec:
373	abate	159	[ [ r = record_spec -> mk loc (Record (true,r))
374			\| "("; t = pat; ")" -> t ] ];
375	abate	4
376			expr_record_spec:
377			[ [ r = LIST1
378	abate	78	[ l = [LIDENT \| UIDENT]; "="; x = expr ->
379	abate	233	(LabelPool.mk l,x) ]
380	abate	4	SEP ";" ->
381	abate	233	mk loc (RecordLitt (make_record loc r))
382	abate	4	] ];
383
384			expr_attrib_spec:
385			[ [ r = expr_record_spec -> r ]
386			\| [ e = expr LEVEL "no_appl" -> e
387	abate	233	\| -> mk loc (RecordLitt (LabelMap.empty))
388	abate	4	]
389			];
390			END
391
392	abate	61	let pat' = Grammar.Entry.create gram "type/pattern expression"
393			EXTEND GLOBAL: pat pat';
394			pat': [ [ p = pat; EOI -> p ] ];
395			END
396
397	abate	10	let pat = Grammar.Entry.parse pat
398	abate	81	and expr = Grammar.Entry.parse expr
399			and prog = Grammar.Entry.parse prog
400	abate	10
401			module From_string = struct
402	abate	61	let pat s = Grammar.Entry.parse pat' (Stream.of_string s)
403	abate	10	let expr s = expr (Stream.of_string s)
404	abate	4	end
405