* http://helm.cs.unibo.it/
*)
-(* $Id$ *)
+(* $Id: grafiteParser.ml 13176 2016-04-18 15:29:33Z fguidi $ *)
module N = NotationPt
module G = GrafiteAst
try
f ()
with
- | Stdpp.Exc_located (_, End_of_file) -> raise End_of_file
- | Stdpp.Exc_located (floc, Stream.Error msg) ->
+ | Ploc.Exc (_, End_of_file) -> raise End_of_file
+ | Ploc.Exc (floc, Stream.Error msg) ->
raise (HExtlib.Localized (floc,CicNotationParser.Parse_error msg))
- | Stdpp.Exc_located (floc, HExtlib.Localized(_,exn)) ->
+ | Ploc.Exc (floc, HExtlib.Localized(_,exn)) ->
raise (HExtlib.Localized
(floc,CicNotationParser.Parse_error (Printexc.to_string exn)))
- | Stdpp.Exc_located (floc, exn) ->
+ | Ploc.Exc (floc, exn) ->
raise (HExtlib.Localized
(floc,CicNotationParser.Parse_error (Printexc.to_string exn)))
let parse_statement grafite_parser parsable =
exc_located_wrapper
- (fun () -> (Grammar.Entry.parse_parsable (Obj.magic grafite_parser) (fst parsable)))
+ (fun () -> (Grammar.Entry.parse_parsable grafite_parser (fst parsable)))
let strm_of_parsable (_,buf) = buf
let default_associativity = Gramext.NonA
-let mk_rec_corec ind_kind defs loc =
- let name,ty =
- match defs with
- | (params,(N.Ident (name, None), ty),_,_) :: _ ->
- let ty = match ty with Some ty -> ty | None -> N.Implicit `JustOne in
- let ty =
- List.fold_right
- (fun var ty -> N.Binder (`Pi,var,ty)
- ) params ty
- in
- name,ty
- | _ -> assert false
- in
- let body = N.Ident (name,None) in
- (loc, N.Theorem(`Definition, name, ty, Some (N.LetRec (ind_kind, defs, body)), `Regular))
+let mk_rec_corec src flavour ind_kind defs loc =
+ let attrs = src, flavour, `Regular in
+ (loc, N.LetRec (ind_kind, defs, attrs))
+
+let nmk_rec_corec src flavour ind_kind defs loc index =
+ let loc,t = mk_rec_corec src flavour ind_kind defs loc in
+ G.NObj (loc,t,index)
-let nmk_rec_corec ind_kind defs loc =
- let loc,t = mk_rec_corec ind_kind defs loc in
- G.NObj (loc,t)
+let shift_vars binder (vars, ty) bo =
+ let map var bo = N.Binder (binder, (var, ty), bo) in
+ List.fold_right map vars bo
+let shift_params binder params bo =
+ List.fold_right (shift_vars binder) params bo
(*
let nnon_punct_of_punct = function
| G.Skip loc -> G.NSkip loc
| IDENT "paramod"
| IDENT "width"
| IDENT "size"
+ | IDENT "nohyps"
+(* | IDENT "timeout" *)
]
];
auto_params: [
loc,path,G.WithoutPreferences
]];
+ index: [[ b = OPT SYMBOL "-" -> match b with None -> true | _ -> false ]];
+
+ source: [[
+ src = OPT [ IDENT "implied" ] ->
+ match src with None -> `Provided | _ -> `Implied
+ ]];
+
grafite_ncommand: [ [
- IDENT "qed" ; b = OPT SYMBOL "-" ->
- let b = match b with None -> true | Some _ -> false in
- G.NQed (loc,b)
- | nflavour = ntheorem_flavour; name = IDENT; SYMBOL ":"; typ = term;
+ lc = lexicon_command -> lc
+ | IDENT "qed" ; i = index -> G.NQed (loc,i)
+ | IDENT "defined" ; i = index -> G.NQed (loc,i) (* FG: presentational qed for definitions *)
+ | src = source; nflavour = ntheorem_flavour; name = IDENT;
+ params = LIST0 protected_binder_vars; SYMBOL ":"; typ = term; (* FG: params added *)
body = OPT [ SYMBOL <:unicode<def>> (* ≝ *); body = term -> body ] ->
- G.NObj (loc, N.Theorem (nflavour, name, typ, body,`Regular))
- | nflavour = ntheorem_flavour; name = IDENT; SYMBOL <:unicode<def>> (* ≝ *);
+ let typ = shift_params `Forall params typ in
+ let body = match body with
+ | Some bo -> Some (shift_params `Lambda params bo)
+ | None -> None
+ in
+ let attrs = src, nflavour, `Regular in
+ G.NObj (loc, N.Theorem (name, typ, body, attrs),true)
+ | src = source; nflavour = ntheorem_flavour; name = IDENT;
+ params = LIST0 protected_binder_vars; SYMBOL <:unicode<def>> (* ≝ *); (* FG: params added *)
body = term ->
- G.NObj (loc, N.Theorem (nflavour, name, N.Implicit `JustOne, Some body,`Regular))
- | IDENT "axiom"; name = IDENT; SYMBOL ":"; typ = term ->
- G.NObj (loc, N.Theorem (`Axiom, name, typ, None, `Regular))
- | IDENT "discriminator" ; indty = tactic_term -> G.NDiscriminator (loc,indty)
- | IDENT "inverter"; name = IDENT; IDENT "for" ; indty = tactic_term ;
- paramspec = OPT inverter_param_list ;
- outsort = OPT [ SYMBOL ":" ; outsort = term -> outsort ] ->
- G.NInverter (loc,name,indty,paramspec,outsort)
- | LETCOREC ; defs = let_codefs ->
- nmk_rec_corec `CoInductive defs loc
- | LETREC ; defs = let_defs ->
- nmk_rec_corec `Inductive defs loc
- | IDENT "inductive"; spec = inductive_spec ->
+ let body = shift_params `Lambda params body in
+ let attrs = src, nflavour, `Regular in
+ G.NObj (loc,
+ N.Theorem(name, N.Implicit `JustOne, Some body, attrs),
+ true)
+ | src = source; IDENT "axiom"; i = index; name = IDENT;
+ params = LIST0 protected_binder_vars; SYMBOL ":"; typ = term -> (* FG: params added *)
+ let typ = shift_params `Forall params typ in
+ let attrs = src, `Axiom, `Regular in
+ G.NObj (loc, N.Theorem (name, typ, None, attrs),i)
+ | src = source; IDENT "inductive"; spec = inductive_spec ->
let (params, ind_types) = spec in
- G.NObj (loc, N.Inductive (params, ind_types))
- | IDENT "coinductive"; spec = inductive_spec ->
+ G.NObj (loc, N.Inductive (params, ind_types, src),true)
+ | src = source; IDENT "coinductive"; spec = inductive_spec ->
let (params, ind_types) = spec in
let ind_types = (* set inductive flags to false (coinductive) *)
List.map (fun (name, _, term, ctors) -> (name, false, term, ctors))
ind_types
in
- G.NObj (loc, N.Inductive (params, ind_types))
- | IDENT "universe"; IDENT "constraint"; u1 = tactic_term;
+ G.NObj (loc, N.Inductive (params, ind_types, src),true)
+ | src = source; IDENT "record" ; (params,name,ty,fields) = record_spec ->
+ G.NObj (loc, N.Record (params,name,ty,fields,src),true)
+(* FG: new syntax for inductive/coinductive definitions and statements *)
+ | src = source; IDENT "rec"; nflavour = ntheorem_flavour; defs = let_defs ->
+ nmk_rec_corec src nflavour `Inductive defs loc true
+ | src = source; IDENT "corec"; nflavour = ntheorem_flavour; defs = let_codefs ->
+ nmk_rec_corec src nflavour `CoInductive defs loc true
+(**)
+ | LETCOREC ; defs = let_codefs ->
+ nmk_rec_corec `Provided `Definition `CoInductive defs loc true
+ | LETREC ; defs = let_defs ->
+ nmk_rec_corec `Provided `Definition `Inductive defs loc true
+ | IDENT "discriminator" ; indty = tactic_term -> G.NDiscriminator (loc,indty)
+ | IDENT "inverter"; name = IDENT; IDENT "for" ; indty = tactic_term ;
+ paramspec = OPT inverter_param_list ;
+ outsort = OPT [ SYMBOL ":" ; outsort = term -> outsort ] ->
+ G.NInverter (loc,name,indty,paramspec,outsort)
+ | IDENT "universe"; cyclic = OPT [ IDENT "cyclic" -> () ] ; IDENT "constraint"; u1 = tactic_term;
SYMBOL <:unicode<lt>> ; u2 = tactic_term ->
+ let acyclic = match cyclic with None -> true | Some () -> false in
let urify = function
| NotationPt.AttributedTerm (_, NotationPt.Sort (`NType i)) ->
NUri.uri_of_string ("cic:/matita/pts/Type"^i^".univ")
in
let u1 = urify u1 in
let u2 = urify u2 in
- G.NUnivConstraint (loc,u1,u2)
+ G.NUnivConstraint (loc,acyclic,u1,u2)
| IDENT "unification"; IDENT "hint"; n = int; t = tactic_term ->
G.UnificationHint (loc, t, n)
| IDENT "coercion"; name = IDENT;
"to"; target = term -> t,ty,(id,source),target ] ->
let compose = compose = None in
G.NCoercion(loc,name,compose,spec)
- | IDENT "record" ; (params,name,ty,fields) = record_spec ->
- G.NObj (loc, N.Record (params,name,ty,fields))
| IDENT "copy" ; s = IDENT; IDENT "from"; u = URI; "with";
m = LIST0 [ u1 = URI; SYMBOL <:unicode<mapsto>>; u2 = URI -> u1,u2 ] ->
G.NCopy (loc,s,NUri.uri_of_string u,
List.map (fun a,b -> NUri.uri_of_string a, NUri.uri_of_string b) m)
- | lc = lexicon_command -> lc
]];
lexicon_command: [ [
projects / helm.git / blobdiff