- let cty,ugraph2 = type_of_constant ~logger uri ugraph1 in
- let cty1 =
- CicSubstitution.subst_vars exp_named_subst cty
- in
- decr fdebug ;
- cty1,ugraph2
- | C.MutInd (uri,i,exp_named_subst) ->
- incr fdebug ;
- let ugraph1 =
- check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
- in
- (* TASSI: da me c'era anche questa, ma in CVS no *)
- let mty,ugraph2 = type_of_mutual_inductive_defs ~logger uri i ugraph1 in
- (* fine parte dubbia *)
- let cty =
- CicSubstitution.subst_vars exp_named_subst mty
- in
- decr fdebug ;
- cty,ugraph2
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let ugraph1 =
- check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
- in
- (* TASSI: idem come sopra *)
- let mty,ugraph2 =
- type_of_mutual_inductive_constr ~logger uri i j ugraph1
- in
- let cty =
- CicSubstitution.subst_vars exp_named_subst mty
- in
- cty,ugraph2
- | C.MutCase (uri,i,outtype,term,pl) ->
- let outsort,ugraph1 = type_of_aux ~logger context outtype ugraph in
- let (need_dummy, k) =
- let rec guess_args context t =
- let outtype = CicReduction.whd ~subst context t in
- match outtype with
- C.Sort _ -> (true, 0)
- | C.Prod (name, s, t) ->
- let (b, n) =
- guess_args ((Some (name,(C.Decl s)))::context) t in
- if n = 0 then
- (* last prod before sort *)
- match CicReduction.whd ~subst context s with
-(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
- C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
- (false, 1)
-(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
- | C.Appl ((C.MutInd (uri',i',_)) :: _)
- when U.eq uri' uri && i' = i -> (false, 1)
- | _ -> (true, 1)
- else
- (b, n + 1)
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- "Malformed case analasys' output type %s"
- (CicPp.ppterm outtype))))
- in
-(*
- let (parameters, arguments, exp_named_subst),ugraph2 =
- let ty,ugraph2 = type_of_aux context term ugraph1 in
- match R.whd ~subst context ty with
- (*CSC manca il caso dei CAST *)
-(*CSC: ma servono i parametri (uri,i)? Se si', perche' non serve anche il *)
-(*CSC: parametro exp_named_subst? Se no, perche' non li togliamo? *)
-(*CSC: Hint: nella DTD servono per gli stylesheet. *)
- C.MutInd (uri',i',exp_named_subst) as typ ->
- if U.eq uri uri' && i = i' then
- ([],[],exp_named_subst),ugraph2
- else
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s, but is expected to be (an application of) %s#1/%d{_}")
- (CicPp.ppterm typ) (U.string_of_uri uri) i)))
- | C.Appl
- ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' ->
- if U.eq uri uri' && i = i' then
- let params,args =
- split tl (List.length tl - k)
- in (params,args,exp_named_subst),ugraph2
- else
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s, "^
- "but is expected to be (an application of) "^
- "%s#1/%d{_}")
- (CicPp.ppterm typ') (U.string_of_uri uri) i)))
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysis: "^
- "analysed term %s is not an inductive one")
- (CicPp.ppterm term))))
-*)
- let (b, k) = guess_args context outsort in
- if not b then (b, k - 1) else (b, k) in
- let (parameters, arguments, exp_named_subst),ugraph2 =
- let ty,ugraph2 = type_of_aux ~logger context term ugraph1 in
- match R.whd ~subst context ty with
- C.MutInd (uri',i',exp_named_subst) as typ ->
- if U.eq uri uri' && i = i' then
- ([],[],exp_named_subst),ugraph2
- else raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
- (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
- | C.Appl ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) ->
- if U.eq uri uri' && i = i' then
- let params,args =
- split tl (List.length tl - k)
- in (params,args,exp_named_subst),ugraph2
- else raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
- (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- "Case analysis: analysed term %s is not an inductive one"
- (CicPp.ppterm term))))
- in
- (*
- let's control if the sort elimination is allowed:
- [(I q1 ... qr)|B]
- *)
- let sort_of_ind_type =
- if parameters = [] then
- C.MutInd (uri,i,exp_named_subst)
- else
- C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters)
- in
- let type_of_sort_of_ind_ty,ugraph3 =
- type_of_aux ~logger context sort_of_ind_type ugraph2 in
- let b,ugraph4 =
- check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
- need_dummy sort_of_ind_type type_of_sort_of_ind_ty outsort ugraph3
- in
- if not b then
- raise
- (TypeCheckerFailure (lazy ("Case analysis: sort elimination not allowed")));
- (* let's check if the type of branches are right *)
- let parsno,constructorsno =
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.InductiveDefinition (il,_,parsno,_) ->
- let _,_,_,cl =
- try List.nth il i with Failure _ -> assert false
- in
- parsno, List.length cl
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if List.length pl <> constructorsno then
- raise (TypeCheckerFailure
- (lazy ("Wrong number of cases in case analysis"))) ;
- let (_,branches_ok,ugraph5) =
- List.fold_left
- (fun (j,b,ugraph) p ->
- if b then
- let cons =
- if parameters = [] then
- (C.MutConstruct (uri,i,j,exp_named_subst))
- else
- (C.Appl
- (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
- in
- let ty_p,ugraph1 = type_of_aux ~logger context p ugraph in
- let ty_cons,ugraph3 = type_of_aux ~logger context cons ugraph1 in
- (* 2 is skipped *)
- let ty_branch =
- type_of_branch ~subst context parsno need_dummy outtype cons
- ty_cons in
- let b1,ugraph4 =
- R.are_convertible
- ~subst ~metasenv context ty_p ty_branch ugraph3
- in
-(* Debugging code
-if not b1 then
-begin
-prerr_endline ("\n!OUTTYPE= " ^ CicPp.ppterm outtype);
-prerr_endline ("!CONS= " ^ CicPp.ppterm cons);
-prerr_endline ("!TY_CONS= " ^ CicPp.ppterm ty_cons);
-prerr_endline ("#### " ^ CicPp.ppterm ty_p ^ "\n<==>\n" ^ CicPp.ppterm ty_branch);
-end;
-*)
- if not b1 then
- debug_print (lazy
- ("#### " ^ CicPp.ppterm ty_p ^
- " <==> " ^ CicPp.ppterm ty_branch));
- (j + 1,b1,ugraph4)
- else
- (j,false,ugraph)
- ) (1,true,ugraph4) pl
- in
- if not branches_ok then
- raise
- (TypeCheckerFailure (lazy "Case analysys: wrong branch type"));
- let arguments' =
- if not need_dummy then outtype::arguments@[term]
- else outtype::arguments in
- let outtype =
- if need_dummy && arguments = [] then outtype
- else CicReduction.head_beta_reduce (C.Appl arguments')
- in
- outtype,ugraph5
- | C.Fix (i,fl) ->
- let types,kl,ugraph1,len =
- List.fold_left
- (fun (types,kl,ugraph,len) (n,k,ty,_) ->
- let _,ugraph1 = type_of_aux ~logger context ty ugraph in
- (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
- k::kl,ugraph1,len+1)
- ) ([],[],ugraph,0) fl
- in
- let ugraph2 =
- List.fold_left
- (fun ugraph (name,x,ty,bo) ->
- let ty_bo,ugraph1 =
- type_of_aux ~logger (types@context) bo ugraph
- in
- let b,ugraph2 =
- R.are_convertible ~subst ~metasenv (types@context)
- ty_bo (CicSubstitution.lift len ty) ugraph1 in
- if b then
- begin
- let (m, eaten, context') =
- eat_lambdas ~subst (types @ context) (x + 1) bo
- in
- (*
- let's control the guarded by
- destructors conditions D{f,k,x,M}
- *)
- if not (guarded_by_destructors ~subst context' eaten
- (len + eaten) kl 1 [] m) then
- raise
- (TypeCheckerFailure
- (lazy ("Fix: not guarded by destructors")))
- else
- ugraph2
- end
- else
- raise (TypeCheckerFailure (lazy ("Fix: ill-typed bodies")))
- ) ugraph1 fl in
- (*CSC: controlli mancanti solo su D{f,k,x,M} *)
- let (_,_,ty,_) = List.nth fl i in
- ty,ugraph2
- | C.CoFix (i,fl) ->
- let types,ugraph1,len =
- List.fold_left
- (fun (l,ugraph,len) (n,ty,_) ->
- let _,ugraph1 =
- type_of_aux ~logger context ty ugraph in
- (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::l,
- ugraph1,len+1)
- ) ([],ugraph,0) fl
- in
- let ugraph2 =
- List.fold_left
- (fun ugraph (_,ty,bo) ->
- let ty_bo,ugraph1 =
- type_of_aux ~logger (types @ context) bo ugraph
- in
- let b,ugraph2 =
- R.are_convertible ~subst ~metasenv (types @ context) ty_bo
- (CicSubstitution.lift len ty) ugraph1
- in
- if b then
- begin
- (* let's control that the returned type is coinductive *)
- match returns_a_coinductive ~subst context ty with
- None ->
- raise
- (TypeCheckerFailure
- (lazy "CoFix: does not return a coinductive type"))
- | Some uri ->
- (*
- let's control the guarded by constructors
- conditions C{f,M}
- *)
- if not (guarded_by_constructors ~subst
- (types @ context) 0 len false bo [] uri) then
- raise
- (TypeCheckerFailure
- (lazy "CoFix: not guarded by constructors"))
- else
- ugraph2
- end
- else
- raise
- (TypeCheckerFailure (lazy "CoFix: ill-typed bodies"))
- ) ugraph1 fl
- in
- let (_,ty,_) = List.nth fl i in
- ty,ugraph2
-
- and check_exp_named_subst ~logger ~subst context ugraph =
- let rec check_exp_named_subst_aux ~logger esubsts l ugraph =
- match l with
- [] -> ugraph
- | ((uri,t) as item)::tl ->
- let ty_uri,ugraph1 = type_of_variable ~logger uri ugraph in
- let typeofvar =
- CicSubstitution.subst_vars esubsts ty_uri in
- let typeoft,ugraph2 = type_of_aux ~logger context t ugraph1 in
- let b,ugraph3 =
- CicReduction.are_convertible ~subst ~metasenv
- context typeoft typeofvar ugraph2
- in
- if b then
- check_exp_named_subst_aux ~logger (esubsts@[item]) tl ugraph3
- else
- begin
- CicReduction.fdebug := 0 ;
- ignore
- (CicReduction.are_convertible
- ~subst ~metasenv context typeoft typeofvar ugraph2) ;
- fdebug := 0 ;
- debug typeoft [typeofvar] ;
- raise (TypeCheckerFailure (lazy "Wrong Explicit Named Substitution"))
- end
- in
- check_exp_named_subst_aux ~logger [] ugraph
-
- and sort_of_prod ~subst context (name,s) (t1, t2) ugraph =
- let module C = Cic in
- let t1' = CicReduction.whd ~subst context t1 in
- let t2' = CicReduction.whd ~subst ((Some (name,C.Decl s))::context) t2 in
- match (t1', t2') with
- (C.Sort s1, C.Sort s2)
- when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
- (* different from Coq manual!!! *)
- C.Sort s2,ugraph
- | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
- (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *)
- let t' = CicUniv.fresh() in
- (try
- let ugraph1 = CicUniv.add_ge t' t1 ugraph in
- let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
- C.Sort (C.Type t'),ugraph2
- with
- CicUniv.UniverseInconsistency msg -> raise (TypeCheckerFailure msg))
- | (C.Sort _,C.Sort (C.Type t1)) ->
- (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *)
- C.Sort (C.Type t1),ugraph (* c'e' bisogno di un fresh? *)
- | (C.Meta _, C.Sort _) -> t2',ugraph
- | (C.Meta _, (C.Meta (_,_) as t))
- | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t ->
- t2',ugraph
- | (_,_) -> raise (TypeCheckerFailure (lazy (sprintf
- "Prod: expected two sorts, found = %s, %s" (CicPp.ppterm t1')
- (CicPp.ppterm t2'))))
-
- and eat_prods ~subst context hetype l ugraph =
- (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
- (*CSC: cucinati *)
- match l with
- [] -> hetype,ugraph
- | (hete, hety)::tl ->
- (match (CicReduction.whd ~subst context hetype) with
- Cic.Prod (n,s,t) ->
- let b,ugraph1 =
-(*if (match hety,s with Cic.Sort _,Cic.Sort _ -> false | _,_ -> true) && hety <> s then(
-prerr_endline ("AAA22: " ^ CicPp.ppterm hete ^ ": " ^ CicPp.ppterm hety ^ " <==> " ^ CicPp.ppterm s); let res = CicReduction.are_convertible ~subst ~metasenv context hety s ugraph in prerr_endline "#"; res) else*)
- CicReduction.are_convertible
- ~subst ~metasenv context hety s ugraph
- in
- if b then
- begin
- CicReduction.fdebug := -1 ;
- eat_prods ~subst context
- (CicSubstitution.subst ~avoid_beta_redexes:true hete t)
- tl ugraph1
- (*TASSI: not sure *)
- end
- else
- begin
- CicReduction.fdebug := 0 ;
- ignore (CicReduction.are_convertible
- ~subst ~metasenv context s hety ugraph) ;
- fdebug := 0 ;
- debug s [hety] ;
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Appl: wrong parameter-type, expected %s, found %s")
- (CicPp.ppterm hetype) (CicPp.ppterm s))))
- end
- | _ ->
- raise (TypeCheckerFailure
- (lazy "Appl: this is not a function, it cannot be applied"))
- )
-
- and returns_a_coinductive ~subst context ty =
- let module C = Cic in
- match CicReduction.whd ~subst context ty with
- C.MutInd (uri,i,_) ->
- (*CSC: definire una funzioncina per questo codice sempre replicato *)
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- (match obj with
- C.InductiveDefinition (itl,_,_,_) ->
- let (_,is_inductive,_,_) = List.nth itl i in
- if is_inductive then None else (Some uri)
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- )
- | C.Appl ((C.MutInd (uri,i,_))::_) ->
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (itl,_,_,_) ->
- let (_,is_inductive,_,_) = List.nth itl i in
- if is_inductive then None else (Some uri)
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- )
- | C.Prod (n,so,de) ->
- returns_a_coinductive ~subst ((Some (n,C.Decl so))::context) de
- | _ -> None
-