]> matita.cs.unibo.it Git - helm.git/blobdiff - helm/ocaml/cic_notation/cicNotationParser.ml
snapshot
[helm.git] / helm / ocaml / cic_notation / cicNotationParser.ml
index f3a6035d4c5d87918d63f3fe78cc1385434c27d6..b64fdb5ee425cdeb31146740e999a1981d7bc902 100644 (file)
@@ -31,7 +31,10 @@ open CicNotationPt
 exception Parse_error of Token.flocation * string
 exception Level_not_found of int
 
-let grammar = Grammar.gcreate CicNotationLexer.notation_lexer
+let level1_pattern_grammar =
+  Grammar.gcreate CicNotationLexer.level1_pattern_lexer
+let level2_ast_grammar = Grammar.gcreate CicNotationLexer.level2_ast_lexer
+let level2_meta_grammar = Grammar.gcreate CicNotationLexer.level2_meta_lexer
 
 let min_precedence = 0
 let max_precedence = 100
@@ -47,14 +50,18 @@ let binder_assoc = Gramext.RightA
 let apply_assoc = Gramext.LeftA
 let simple_assoc = Gramext.NonA
 
-let level1_pattern = Grammar.Entry.create grammar "level1_pattern"
-let level2_pattern = Grammar.Entry.create grammar "level2_pattern"
-let level3_term = Grammar.Entry.create grammar "level3_term"
-let l2_pattern = Grammar.Entry.create grammar "l2_pattern"
-let notation = Grammar.Entry.create grammar "notation" (* level1 <-> level 2 *)
-let interpretation =
-  Grammar.Entry.create grammar "interpretation" (* level2 <-> level 3 *)
-let phrase = Grammar.Entry.create grammar "phrase"
+let level1_pattern =
+  Grammar.Entry.create level1_pattern_grammar "level1_pattern"
+let level2_ast = Grammar.Entry.create level2_ast_grammar "level2_ast"
+let term = Grammar.Entry.create level2_ast_grammar "term"
+let level2_meta = Grammar.Entry.create level2_meta_grammar "level2_meta"
+
+let level3_term = Grammar.Entry.create level2_ast_grammar "level3_term"
+let notation =  (* level1 <-> level 2 *)
+  Grammar.Entry.create level2_ast_grammar "notation"
+let interpretation =    (* level2 <-> level 3 *)
+  Grammar.Entry.create level2_ast_grammar "interpretation"
+let phrase = Grammar.Entry.create level2_ast_grammar "phrase"
 
 let return_term loc term = ()
 
@@ -73,7 +80,6 @@ let int_of_string s =
 let symbol s = Gramext.Stoken ("SYMBOL", s)
 let ident s = Gramext.Stoken ("IDENT", s)
 let number s = Gramext.Stoken ("NUMBER", s)
-let term = Gramext.Sself
 
 let g_symbol_of_literal =
   function
@@ -143,18 +149,18 @@ let extract_term_production pattern =
     | `Keyword s -> [NoBinding, ident s]
     | `Number s -> [NoBinding, number s]
   and aux_layout = function
-    | Sub (p1, p2) -> aux p1 @ [NoBinding, symbol "\\SUB"] @ aux p2
-    | Sup (p1, p2) -> aux p1 @ [NoBinding, symbol "\\SUP"] @ aux p2
-    | Below (p1, p2) -> aux p1 @ [NoBinding, symbol "\\BELOW"] @ aux p2
-    | Above (p1, p2) -> aux p1 @ [NoBinding, symbol "\\ABOVE"] @ aux p2
-    | Frac (p1, p2) -> aux p1 @ [NoBinding, symbol "\\FRAC"] @ aux p2
-    | Atop (p1, p2) -> aux p1 @ [NoBinding, symbol "\\ATOP"] @ aux p2
-    | Over (p1, p2) -> aux p1 @ [NoBinding, symbol "\\OVER"] @ aux p2
+    | Sub (p1, p2) -> aux p1 @ [NoBinding, symbol "\\sub"] @ aux p2
+    | Sup (p1, p2) -> aux p1 @ [NoBinding, symbol "\\sup"] @ aux p2
+    | Below (p1, p2) -> aux p1 @ [NoBinding, symbol "\\below"] @ aux p2
+    | Above (p1, p2) -> aux p1 @ [NoBinding, symbol "\\above"] @ aux p2
+    | Frac (p1, p2) -> aux p1 @ [NoBinding, symbol "\\frac"] @ aux p2
+    | Atop (p1, p2) -> aux p1 @ [NoBinding, symbol "\\atop"] @ aux p2
+    | Over (p1, p2) -> aux p1 @ [NoBinding, symbol "\\over"] @ aux p2
     | Root (p1, p2) ->
-        [NoBinding, symbol "\\ROOT"] @ aux p2 @ [NoBinding, symbol "\\OF"]
+        [NoBinding, symbol "\\root"] @ aux p2 @ [NoBinding, symbol "\\of"]
         @ aux p1
-    | Sqrt p -> [NoBinding, symbol "\\SQRT"] @ aux p
-(*     | Break -> [] *)
+    | Sqrt p -> [NoBinding, symbol "\\sqrt"] @ aux p
+    | Break -> []
     | Box (_, pl) -> List.flatten (List.map aux pl)
   and aux_magic magic =
     match magic with
@@ -205,14 +211,13 @@ let extract_term_production pattern =
   and aux_variable =
     function
     | NumVar s -> [Binding (s, NumType), number ""]
-    | TermVar s -> [Binding (s, TermType), term]
+    | TermVar s -> [Binding (s, TermType), Gramext.Sself]
     | IdentVar s -> [Binding (s, StringType), ident ""]
     | Ascription (p, s) -> assert false (* TODO *)
     | FreshVar _ -> assert false
   and inner_pattern p =
     let p_bindings, p_atoms = List.split (aux p) in
     let p_names = flatten_opt p_bindings in
-    let _ = prerr_endline ("inner names: " ^ String.concat " " (List.map fst p_names)) in
     let action =
       make_action (fun (env : CicNotationEnv.t) (loc : location) -> env)
         p_bindings
@@ -237,9 +242,8 @@ let extend level1_pattern ?(precedence = default_precedence)
   let level = level_of_int precedence in
   let p_names = flatten_opt p_bindings in
   let _ =
-    prerr_endline (string_of_int (List.length p_bindings));
     Grammar.extend
-      [ Grammar.Entry.obj (l2_pattern: 'a Grammar.Entry.e),
+      [ Grammar.Entry.obj (term: 'a Grammar.Entry.e),
         Some (Gramext.Level level),
         [ None,
           associativity,
@@ -250,10 +254,14 @@ let extend level1_pattern ?(precedence = default_precedence)
   in
   p_atoms
 
-let delete atoms = Grammar.delete_rule l2_pattern atoms
+let delete atoms = Grammar.delete_rule term atoms
 
 (** {2 Grammar} *)
 
+let parse_level1_pattern_ref = ref (fun _ -> assert false)
+let parse_level2_ast_ref = ref (fun _ -> assert false)
+let parse_level2_meta_ref = ref (fun _ -> assert false)
+
 let fold_binder binder pt_names body =
   let fold_cluster binder terms ty body =
     List.fold_right
@@ -266,7 +274,7 @@ let fold_binder binder pt_names body =
 
 let return_term loc term = AttributedTerm (`Loc loc, term)
 
-let _ = (* create empty precedence level for "l2_pattern" *)
+let _ = (* create empty precedence level for "term" *)
   let mk_level_list first last =
     let rec aux acc = function
       | i when i < first -> acc
@@ -275,96 +283,131 @@ let _ = (* create empty precedence level for "l2_pattern" *)
     aux [] last
   in
   Grammar.extend
-    [ Grammar.Entry.obj (l2_pattern: 'a Grammar.Entry.e),
+    [ Grammar.Entry.obj (term: 'a Grammar.Entry.e),
       None,
       mk_level_list min_precedence max_precedence ]
 
-EXTEND
-  GLOBAL: level1_pattern level2_pattern level3_term
-          l2_pattern
-          notation interpretation
-          phrase;
 (* {{{ Grammar for concrete syntax patterns, notation level 1 *)
-  level1_pattern: [ [ p = l1_simple_pattern -> p ] ];
+EXTEND
+  GLOBAL: level1_pattern;
+
+  level1_pattern: [ [ p = l1_pattern; EOI -> CicNotationUtil.boxify p ] ];
   l1_pattern: [ [ p = LIST1 l1_simple_pattern -> p ] ];
   literal: [
     [ s = SYMBOL -> `Symbol s
-    | k = KEYWORD -> `Keyword k
+    | k = QKEYWORD -> `Keyword k
     | n = NUMBER -> `Number n
     ]
   ];
-  sep:       [ [ SYMBOL "\\SEP";      sep = literal -> sep ] ];
-(*   row_sep:   [ [ SYMBOL "\\ROWSEP";   sep = literal -> sep ] ];
-  field_sep: [ [ SYMBOL "\\FIELDSEP"; sep = literal -> sep ] ]; *)
+  sep:       [ [ "sep";      sep = literal -> sep ] ];
+(*   row_sep:   [ [ "rowsep";   sep = literal -> sep ] ];
+  field_sep: [ [ "fieldsep"; sep = literal -> sep ] ]; *)
   l1_magic_pattern: [
-    [ SYMBOL "\\LIST0"; p = l1_simple_pattern; sep = OPT sep -> List0 (p, sep)
-    | SYMBOL "\\LIST1"; p = l1_simple_pattern; sep = OPT sep -> List1 (p, sep)
-    | SYMBOL "\\OPT";   p = l1_simple_pattern -> Opt p
+    [ "list0"; p = l1_simple_pattern; sep = OPT sep -> List0 (p, sep)
+    | "list1"; p = l1_simple_pattern; sep = OPT sep -> List1 (p, sep)
+    | "opt";   p = l1_simple_pattern -> Opt p
     ]
   ];
   l1_pattern_variable: [
-    [ SYMBOL "\\TERM"; id = IDENT -> TermVar id
-    | SYMBOL "\\NUM"; id = IDENT -> NumVar id
-    | SYMBOL "\\IDENT"; id = IDENT -> IdentVar id
+    [ "term"; id = IDENT -> TermVar id
+    | "number"; id = IDENT -> NumVar id
+    | "ident"; id = IDENT -> IdentVar id
     ]
   ];
   l1_simple_pattern:
     [ "layout" LEFTA
-      [ p1 = SELF; SYMBOL "\\SUB"; p2 = SELF ->
+      [ p1 = SELF; SYMBOL "\\sub"; p2 = SELF ->
           return_term loc (Layout (Sub (p1, p2)))
-      | p1 = SELF; SYMBOL "\\SUP"; p2 = SELF ->
+      | p1 = SELF; SYMBOL "\\sup"; p2 = SELF ->
           return_term loc (Layout (Sup (p1, p2)))
-      | p1 = SELF; SYMBOL "\\BELOW"; p2 = SELF ->
+      | p1 = SELF; SYMBOL "\\below"; p2 = SELF ->
           return_term loc (Layout (Below (p1, p2)))
-      | p1 = SELF; SYMBOL "\\ABOVE"; p2 = SELF ->
+      | p1 = SELF; SYMBOL "\\above"; p2 = SELF ->
           return_term loc (Layout (Above (p1, p2)))
-      | p1 = SELF; SYMBOL "\\OVER"; p2 = SELF ->
+      | p1 = SELF; SYMBOL "\\over"; p2 = SELF ->
           return_term loc (Layout (Over (p1, p2)))
-      | p1 = SELF; SYMBOL "\\ATOP"; p2 = SELF ->
+      | p1 = SELF; SYMBOL "\\atop"; p2 = SELF ->
           return_term loc (Layout (Atop (p1, p2)))
-(*       | SYMBOL "\\ARRAY"; p = SELF; csep = OPT field_sep; rsep = OPT row_sep ->
+(*       | "array"; p = SELF; csep = OPT field_sep; rsep = OPT row_sep ->
           return_term loc (Array (p, csep, rsep)) *)
-      | SYMBOL "\\FRAC"; p1 = SELF; p2 = SELF ->
+      | SYMBOL "\\frac"; p1 = SELF; p2 = SELF ->
           return_term loc (Layout (Frac (p1, p2)))
-      | SYMBOL "\\SQRT"; p = SELF -> return_term loc (Layout (Sqrt p))
-      | SYMBOL "\\ROOT"; index = SELF; SYMBOL "\\OF"; arg = SELF ->
-          return_term loc (Layout (Root (arg, index)));
-      | SYMBOL "\\HBOX"; DELIM "\\["; p = l1_pattern; DELIM "\\]" ->
-          return_term loc (Layout (Box ((H, false, false), p)))
-      | SYMBOL "\\VBOX"; DELIM "\\["; p = l1_pattern; DELIM "\\]" ->
-          return_term loc (Layout (Box ((V, false, false), p)))
-      | SYMBOL "\\HVBOX"; DELIM "\\["; p = l1_pattern; DELIM "\\]" ->
-          return_term loc (Layout (Box ((HV, false, false), p)))
-      | SYMBOL "\\HOVBOX"; DELIM "\\["; p = l1_pattern; DELIM "\\]" ->
-          return_term loc (Layout (Box ((HOV, false, false), p)))
-(*       | SYMBOL "\\BREAK" -> return_term loc (Layout Break) *)
+      | SYMBOL "\\sqrt"; p = SELF -> return_term loc (Layout (Sqrt p))
+      | SYMBOL "\\root"; index = SELF; SYMBOL "\\OF"; arg = SELF ->
+          return_term loc (Layout (Root (arg, index)))
+      | "hbox"; LPAREN; p = l1_pattern; RPAREN ->
+          return_term loc (CicNotationUtil.boxify p)
+      | "vbox"; LPAREN; p = l1_pattern; RPAREN ->
+          return_term loc (CicNotationUtil.boxify p)
+      | "hvbox"; LPAREN; p = l1_pattern; RPAREN ->
+          return_term loc (CicNotationUtil.boxify p)
+      | "hovbox"; LPAREN; p = l1_pattern; RPAREN ->
+          return_term loc (CicNotationUtil.boxify p)
+      | "break" -> return_term loc (Layout Break)
 (*       | SYMBOL "\\SPACE" -> return_term loc (Layout Space) *)
-      | DELIM "\\["; p = l1_pattern; DELIM "\\]" ->
+      | "LPAREN"; p = l1_pattern; "RPAREN" ->
           return_term loc (CicNotationUtil.boxify p)
-      | p = SELF; SYMBOL "\\AS"; id = IDENT ->
-          return_term loc (Variable (Ascription (p, id)))
       ]
     | "simple" NONA
-      [ i = IDENT -> return_term loc (Ident (i, None))
+      [ i = IDENT -> return_term loc (Variable (TermVar i))
       | m = l1_magic_pattern -> return_term loc (Magic m)
       | v = l1_pattern_variable -> return_term loc (Variable v)
       | l = literal -> return_term loc (Literal l)
       ]
     ];
+  END
 (* }}} *)
+
+
+EXTEND
+  GLOBAL: level2_meta;
+  l2_variable: [
+    [ "term"; id = IDENT -> TermVar id
+    | "number"; id = IDENT -> NumVar id
+    | "ident"; id = IDENT -> IdentVar id
+    | "fresh"; id = IDENT -> FreshVar id
+    | "anonymous" -> TermVar "_"
+    | id = IDENT -> TermVar id
+    ]
+  ];
+  l2_magic: [
+    [ "fold"; kind = [ "left" -> `Left | "right" -> `Right ];
+      base = level2_meta; "rec"; id = IDENT; recursive = level2_meta ->
+        Fold (kind, base, [id], recursive)
+    | "default"; some = level2_meta; none = level2_meta -> Default (some, none)
+    | "if"; p_test = level2_meta;
+      "then"; p_true = level2_meta;
+      "else"; p_false = level2_meta ->
+        If (p_test, p_true, p_false)
+    | "fail" -> Fail
+    ]
+  ];
+  level2_meta: [
+    [ magic = l2_magic -> Magic magic
+    | var = l2_variable -> Variable var
+    | blob = UNPARSED_AST -> !parse_level2_ast_ref (Stream.of_string blob)
+    ]
+  ];
+END
+
+EXTEND
+  GLOBAL: level2_ast term
+          level3_term
+          notation interpretation
+          phrase;
 (* {{{ Grammar for ast patterns, notation level 2 *)
-  level2_pattern: [ [ p = l2_pattern -> p ] ];
+  level2_ast: [ [ p = term -> p ] ];
   sort: [
-    [ SYMBOL "\\PROP" -> `Prop
-    | SYMBOL "\\SET" -> `Set
-    | SYMBOL "\\TYPE" -> `Type
+    [ IDENT "Prop" -> `Prop
+    | IDENT "Set" -> `Set
+    | IDENT "Type" -> `Type
     ]
   ];
   explicit_subst: [
     [ SYMBOL "\\subst";  (* to avoid catching frequent "a [1]" cases *)
       SYMBOL "[";
       substs = LIST1 [
-        i = IDENT; SYMBOL <:unicode<Assign>> (* ≔ *); t = l2_pattern -> (i, t)
+        i = IDENT; SYMBOL <:unicode<Assign>> (* ≔ *); t = term -> (i, t)
       ] SEP SYMBOL ";";
       SYMBOL "]" ->
         substs
@@ -372,20 +415,20 @@ EXTEND
   ];
   meta_subst: [
     [ s = SYMBOL "_" -> None
-    | p = l2_pattern -> Some p ]
+    | p = term -> Some p ]
   ];
   meta_substs: [
     [ SYMBOL "["; substs = LIST0 meta_subst; SYMBOL "]" -> substs ]
   ];
   possibly_typed_name: [
-    [ SYMBOL "("; id = bound_name; SYMBOL ":"; typ = l2_pattern; SYMBOL ")" ->
+    [ LPAREN; id = bound_name; SYMBOL ":"; typ = term; RPAREN ->
         id, Some typ
     | id = bound_name -> id, None
     ]
   ];
   match_pattern: [
     [ id = IDENT -> id, []
-    | SYMBOL "("; id = IDENT; vars = LIST1 possibly_typed_name; SYMBOL ")" ->
+    | LPAREN; id = IDENT; vars = LIST1 possibly_typed_name; RPAREN ->
         id, vars
     ]
   ];
@@ -403,13 +446,13 @@ EXTEND
   ];
   bound_names: [
     [ vars = LIST1 bound_name SEP SYMBOL ",";
-      ty = OPT [ SYMBOL ":"; p = l2_pattern -> p ] ->
+      ty = OPT [ SYMBOL ":"; p = term -> p ] ->
         [ vars, ty ]
     | clusters = LIST1 [
-        SYMBOL "(";
+        LPAREN;
         vars = LIST1 bound_name SEP SYMBOL ",";
-        ty = OPT [ SYMBOL ":"; p = l2_pattern -> p ];
-        SYMBOL ")" ->
+        ty = OPT [ SYMBOL ":"; p = term -> p ];
+        RPAREN ->
           vars, ty
       ] ->
         clusters
@@ -424,8 +467,8 @@ EXTEND
     [ defs = LIST1 [
         name = bound_name; args = bound_names;
         index_name = OPT [ IDENT "on"; id = bound_name -> id ];
-        ty = OPT [ SYMBOL ":" ; p = l2_pattern -> p ];
-        SYMBOL <:unicode<def>> (* ≝ *); body = l2_pattern ->
+        ty = OPT [ SYMBOL ":" ; p = term -> p ];
+        SYMBOL <:unicode<def>> (* ≝ *); body = term ->
           let body = fold_binder `Lambda args body in
           let ty = 
             match ty with 
@@ -456,53 +499,25 @@ EXTEND
         defs
     ]
   ];
-  l2_pattern_variable: [
-    [ SYMBOL "\\TERM"; id = IDENT -> TermVar id
-    | SYMBOL "\\NUM"; id = IDENT -> NumVar id
-    | SYMBOL "\\IDENT"; id = IDENT -> IdentVar id
-    | SYMBOL "\\FRESH"; id = IDENT -> FreshVar id
-    ]
-  ];
-  l2_magic_pattern: [
-    [ SYMBOL "\\FOLD";
-      kind = [ IDENT "left" -> `Left | IDENT "right" -> `Right ];
-      DELIM "\\["; base = l2_pattern; DELIM "\\]";
-      SYMBOL "\\LAMBDA"; id = IDENT;
-      DELIM "\\["; recursive = l2_pattern; DELIM "\\]" ->
-        Fold (kind, base, [id], recursive)
-    | SYMBOL "\\DEFAULT";
-      DELIM "\\["; some = l2_pattern; DELIM "\\]";
-      DELIM "\\["; none = l2_pattern; DELIM "\\]" ->
-        Default (some, none)
-    | SYMBOL "\\IF";
-      DELIM "\\["; guard = l2_pattern; DELIM "\\]";
-      DELIM "\\["; p = l2_pattern; DELIM "\\]" ->
-        If (guard, p)    
-    | SYMBOL "\\UNLESS";
-      DELIM "\\["; guard = l2_pattern; DELIM "\\]";
-      DELIM "\\["; p = l2_pattern; DELIM "\\]" ->
-        Unless (guard, p)        
-    ]
-  ];
-  l2_pattern: LEVEL "10"  (* let in *)
+  term: LEVEL "10"  (* let in *)
     [ "10" NONA
       [ IDENT "let"; var = possibly_typed_name; SYMBOL <:unicode<def>> (* ≝ *);
-        p1 = l2_pattern; "in"; p2 = l2_pattern ->
+        p1 = term; "in"; p2 = term ->
           return_term loc (LetIn (var, p1, p2))
       | IDENT "let"; k = induction_kind; defs = let_defs; IDENT "in";
-        body = l2_pattern ->
+        body = term ->
           return_term loc (LetRec (k, defs, body))
       ]
     ];
-  l2_pattern: LEVEL "20"  (* binder *)
+  term: LEVEL "20"  (* binder *)
     [ "20" RIGHTA
-      [ b = binder; names = bound_names; SYMBOL "."; body = l2_pattern ->
+      [ b = binder; names = bound_names; SYMBOL "."; body = term ->
           return_term loc (fold_binder b names body)
       ]
     ];
-  l2_pattern: LEVEL "70"  (* apply *)
+  term: LEVEL "70"  (* apply *)
     [ "70" LEFTA
-      [ p1 = l2_pattern; p2 = l2_pattern ->
+      [ p1 = term; p2 = term ->
           let rec aux = function
             | Appl (hd :: tl)
             | AttributedTerm (_, Appl (hd :: tl)) ->
@@ -512,7 +527,7 @@ EXTEND
           return_term loc (Appl (aux p1 @ [p2]))
       ]
     ];
-  l2_pattern: LEVEL "90"  (* simple *)
+  term: LEVEL "90"  (* simple *)
     [ "90" NONA
       [ id = IDENT -> return_term loc (Ident (id, None))
       | id = IDENT; s = explicit_subst -> return_term loc (Ident (id, Some s))
@@ -523,22 +538,21 @@ EXTEND
       | m = META -> return_term loc (Meta (int_of_string m, []))
       | m = META; s = meta_substs -> return_term loc (Meta (int_of_string m, s))
       | s = sort -> return_term loc (Sort s)
-      | outtyp = OPT [ SYMBOL "["; ty = l2_pattern; SYMBOL "]" -> ty ];
-        IDENT "match"; t = l2_pattern;
+      | outtyp = OPT [ SYMBOL "["; ty = term; SYMBOL "]" -> ty ];
+        IDENT "match"; t = term;
         indty_ident = OPT [ SYMBOL ":"; id = IDENT -> id ];
         IDENT "with"; SYMBOL "[";
         patterns = LIST0 [
           lhs = match_pattern; SYMBOL <:unicode<Rightarrow>> (* ⇒ *);
-          rhs = l2_pattern ->
+          rhs = term ->
             lhs, rhs
         ] SEP SYMBOL "|";
         SYMBOL "]" ->
           return_term loc (Case (t, indty_ident, outtyp, patterns))
-      | SYMBOL "("; p1 = l2_pattern; SYMBOL ":"; p2 = l2_pattern; SYMBOL ")" ->
+      | LPAREN; p1 = term; SYMBOL ":"; p2 = term; RPAREN ->
           return_term loc (Appl [ Symbol ("cast", 0); p1; p2 ])
-      | SYMBOL "("; p = l2_pattern; SYMBOL ")" -> p
-      | v = l2_pattern_variable -> return_term loc (Variable v)
-      | m = l2_magic_pattern -> return_term loc (Magic m)
+      | LPAREN; p = term; RPAREN -> p
+      | blob = UNPARSED_META -> !parse_level2_meta_ref (Stream.of_string blob)
       ]
     ];
 (* }}} *)
@@ -553,7 +567,7 @@ EXTEND
   level3_term: [
     [ u = URI -> UriPattern (UriManager.uri_of_string u)
     | id = IDENT -> VarPattern id
-    | SYMBOL "("; terms = LIST1 SELF; SYMBOL ")" ->
+    | LPAREN; terms = LIST1 SELF; RPAREN ->
         (match terms with
         | [] -> assert false
         | [term] -> term
@@ -572,10 +586,15 @@ EXTEND
     [ IDENT "with"; IDENT "precedence"; n = NUMBER -> int_of_string n ]
   ];
   notation: [
-    [ p1 = level1_pattern;
+    [ s = QSTRING;
       assoc = OPT associativity; prec = OPT precedence;
-      IDENT "for"; p2 = level2_pattern ->
-        (p1, assoc, prec, p2)
+      IDENT "for";
+      p2 = 
+        [ blob = UNPARSED_AST -> !parse_level2_ast_ref (Stream.of_string blob)
+        | blob = UNPARSED_META ->
+            !parse_level2_meta_ref (Stream.of_string blob) ]
+      ->
+        (!parse_level1_pattern_ref (Stream.of_string s), assoc, prec, p2)
     ]
   ];
   interpretation: [
@@ -586,7 +605,7 @@ EXTEND
 (* }}} *)
 (* {{{ Top-level phrases *)
   phrase: [
-    [ IDENT "print"; p2 = level2_pattern; SYMBOL "." -> Print p2
+    [ IDENT "print"; t = term; SYMBOL "." -> Print t
     | IDENT "notation"; (l1, assoc, prec, l2) = notation; SYMBOL "." ->
         Notation (l1, assoc, prec, l2)
     | IDENT "interpretation"; (symbol, args, l3) = interpretation; SYMBOL "." ->
@@ -608,19 +627,26 @@ let exc_located_wrapper f =
   | Stdpp.Exc_located (floc, exn) ->
       raise (Parse_error (floc, (Printexc.to_string exn)))
 
-let parse_syntax_pattern stream =
+let parse_level1_pattern stream =
   exc_located_wrapper (fun () -> Grammar.Entry.parse level1_pattern stream)
-let parse_ast_pattern stream =
-  exc_located_wrapper (fun () -> Grammar.Entry.parse level2_pattern stream)
+let parse_level2_ast stream =
+  exc_located_wrapper (fun () -> Grammar.Entry.parse level2_ast stream)
+let parse_level2_meta stream =
+  exc_located_wrapper (fun () -> Grammar.Entry.parse level2_meta stream)
 let parse_interpretation stream =
   exc_located_wrapper (fun () -> Grammar.Entry.parse level3_term stream)
 let parse_phrase stream =
   exc_located_wrapper (fun () -> Grammar.Entry.parse phrase stream)
 
+let _ =
+  parse_level1_pattern_ref := parse_level1_pattern;
+  parse_level2_ast_ref := parse_level2_ast;
+  parse_level2_meta_ref := parse_level2_meta
+
 (** {2 Debugging} *)
 
 let print_l2_pattern () =
-  Grammar.print_entry Format.std_formatter (Grammar.Entry.obj l2_pattern);
+  Grammar.print_entry Format.std_formatter (Grammar.Entry.obj term);
   Format.pp_print_flush Format.std_formatter ();
   flush stdout