exception NotGuarded of string Lazy.t;;
+let type_of_branch ~subst context leftno outty cons tycons =
+ let rec aux liftno context cons tycons =
+ match R.whd ~subst context tycons with
+ | C.Const (Ref.Ref (_,Ref.Ind _)) -> C.Appl [S.lift liftno outty ; cons]
+ | C.Appl (C.Const (Ref.Ref (_,Ref.Ind _))::tl) ->
+ let _,arguments = HExtlib.split_nth leftno tl in
+ C.Appl (S.lift liftno outty::arguments@[cons])
+ | C.Prod (name,so,de) ->
+ let cons =
+ match S.lift 1 cons with
+ | C.Appl l -> C.Appl (l@[C.Rel 1])
+ | t -> C.Appl [t ; C.Rel 1]
+ in
+ C.Prod (name,so, aux (liftno+1) ((name,(C.Decl so))::context) cons de)
+ | _ -> raise (AssertFailure (lazy "type_of_branch"))
+ in
+ aux 0 context cons tycons
+;;
+
+
let rec typeof ~subst ~metasenv context term =
let rec typeof_aux context =
fun t -> (*prerr_endline (PP.ppterm ~metasenv ~subst ~context t);*)
let ty_p = typeof_aux context p in
let ty_cons = typeof_aux context cons in
let ty_branch =
- type_of_branch ~subst context leftno outtype cons ty_cons 0
+ type_of_branch ~subst context leftno outtype cons ty_cons
in
j+1, R.are_convertible ~subst context ty_p ty_branch,
ty_p, ty_branch
R.head_beta_reduce (C.Appl res)
| C.Match _ -> assert false
- and type_of_branch ~subst context leftno outty cons tycons liftno =
- match R.whd ~subst context tycons with
- | C.Const (Ref.Ref (_,Ref.Ind _)) -> C.Appl [S.lift liftno outty ; cons]
- | C.Appl (C.Const (Ref.Ref (_,Ref.Ind _))::tl) ->
- let _,arguments = HExtlib.split_nth leftno tl in
- C.Appl (S.lift liftno outty::arguments@[cons])
- | C.Prod (name,so,de) ->
- let cons =
- match S.lift 1 cons with
- | C.Appl l -> C.Appl (l@[C.Rel 1])
- | t -> C.Appl [t ; C.Rel 1]
- in
- C.Prod (name,so,
- type_of_branch ~subst ((name,(C.Decl so))::context)
- leftno outty cons de (liftno+1))
- | _ -> raise (AssertFailure (lazy "type_of_branch"))
-
(* check_metasenv_consistency checks that the "canonical" context of a
metavariable is consitent - up to relocation via the relocation list l -
with the actual context *)
"Local and canonical context %s have different lengths"
(PP.ppterm ~subst ~metasenv ~context term))))
- and check_allowed_sort_elimination ~subst ~metasenv r =
- let mkapp he arg =
- match he with
- | C.Appl l -> C.Appl (l @ [arg])
- | t -> C.Appl [t;arg] in
- let rec aux context ind arity1 arity2 =
- let arity1 = R.whd ~subst context arity1 in
- let arity2 = R.whd ~subst context arity2 in
- match arity1,arity2 with
- | C.Prod (name,so1,de1), C.Prod (_,so2,de2) ->
- if not (R.are_convertible ~subst context so1 so2) then
- raise (TypeCheckerFailure (lazy (Printf.sprintf
- "In outtype: expected %s, found %s"
- (PP.ppterm ~subst ~metasenv ~context so1)
- (PP.ppterm ~subst ~metasenv ~context so2)
- )));
- aux ((name, C.Decl so1)::context)
- (mkapp (S.lift 1 ind) (C.Rel 1)) de1 de2
- | C.Sort _, C.Prod (name,so,ta) ->
- if not (R.are_convertible ~subst context so ind) then
- raise (TypeCheckerFailure (lazy (Printf.sprintf
- "In outtype: expected %s, found %s"
- (PP.ppterm ~subst ~metasenv ~context ind)
- (PP.ppterm ~subst ~metasenv ~context so)
- )));
- (match arity1, R.whd ~subst ((name,C.Decl so)::context) ta with
- | (C.Sort C.Type _, C.Sort _)
- | (C.Sort C.Prop, C.Sort C.Prop) -> ()
- | (C.Sort C.Prop, C.Sort C.Type _) ->
- (* TODO: we should pass all these parameters since we
- * have them already *)
- let _,leftno,itl,_,i = E.get_checked_indtys r in
- let itl_len = List.length itl in
- let _,itname,ittype,cl = List.nth itl i in
- let cl_len = List.length cl in
- (* is it a singleton, non recursive and non informative
- definition or an empty one? *)
- if not
- (cl_len = 0 ||
- (itl_len = 1 && cl_len = 1 &&
- let _,_,constrty = List.hd cl in
- is_non_recursive_singleton r itname ittype constrty &&
- is_non_informative leftno constrty))
- then
- raise (TypeCheckerFailure (lazy
- ("Sort elimination not allowed")));
- | _,_ -> ())
- | _,_ -> ()
- in
- aux
-
in
typeof_aux context term
+and check_allowed_sort_elimination ~subst ~metasenv r =
+ let mkapp he arg =
+ match he with
+ | C.Appl l -> C.Appl (l @ [arg])
+ | t -> C.Appl [t;arg] in
+ let rec aux context ind arity1 arity2 =
+ let arity1 = R.whd ~subst context arity1 in
+ let arity2 = R.whd ~subst context arity2 in
+ match arity1,arity2 with
+ | C.Prod (name,so1,de1), C.Prod (_,so2,de2) ->
+ if not (R.are_convertible ~subst context so1 so2) then
+ raise (TypeCheckerFailure (lazy (Printf.sprintf
+ "In outtype: expected %s, found %s"
+ (PP.ppterm ~subst ~metasenv ~context so1)
+ (PP.ppterm ~subst ~metasenv ~context so2)
+ )));
+ aux ((name, C.Decl so1)::context)
+ (mkapp (S.lift 1 ind) (C.Rel 1)) de1 de2
+ | C.Sort _, C.Prod (name,so,ta) ->
+ if not (R.are_convertible ~subst context so ind) then
+ raise (TypeCheckerFailure (lazy (Printf.sprintf
+ "In outtype: expected %s, found %s"
+ (PP.ppterm ~subst ~metasenv ~context ind)
+ (PP.ppterm ~subst ~metasenv ~context so)
+ )));
+ (match arity1, R.whd ~subst ((name,C.Decl so)::context) ta with
+ | (C.Sort C.Type _, C.Sort _)
+ | (C.Sort C.Prop, C.Sort C.Prop) -> ()
+ | (C.Sort C.Prop, C.Sort C.Type _) ->
+ (* TODO: we should pass all these parameters since we
+ * have them already *)
+ let _,leftno,itl,_,i = E.get_checked_indtys r in
+ let itl_len = List.length itl in
+ let _,itname,ittype,cl = List.nth itl i in
+ let cl_len = List.length cl in
+ (* is it a singleton, non recursive and non informative
+ definition or an empty one? *)
+ if not
+ (cl_len = 0 ||
+ (itl_len = 1 && cl_len = 1 &&
+ let _,_,constrty = List.hd cl in
+ is_non_recursive_singleton r itname ittype constrty &&
+ is_non_informative leftno constrty))
+ then
+ raise (TypeCheckerFailure (lazy
+ ("Sort elimination not allowed")));
+ | _,_ -> ())
+ | _,_ -> ()
+ in
+ aux
+
and eat_prods ~subst ~metasenv context he ty_he args_with_ty =
let rec aux ty_he = function
| [] -> ty_he
projects / helm.git / blobdiff