- | C.Appl _ -> assert false
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outty,t,pl) ->
- C.MutCase (sp, cookingsno, i, um_aux outty, um_aux t,
- List.map um_aux pl)
- | C.Fix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo))
- fl
- in
- C.Fix (i, liftedfl)
- | C.CoFix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo))
- fl
- in
- C.CoFix (i, liftedfl)
- in
- um_aux t
-;;
-
-(* UNWIND THE MGU INSIDE THE MGU *)
-let unwind_subst metasenv subst =
- let identity_relocation_list_for_metavariable i =
- let (_,canonical_context,_) =
- List.find (function (m,_,_) -> m=i) metasenv
- in
- let canonical_context_length = List.length canonical_context in
- let rec aux =
- function
- n when n > canonical_context_length -> []
- | n -> (Some (Cic.Rel n))::(aux (n+1))
- in
- aux 1
- in
- List.fold_left
- (fun (unwinded,metasenv) (i,_) ->
- let identity_relocation_list =
- identity_relocation_list_for_metavariable i
- in
- let (_,metasenv',subst') =
- unwind metasenv subst unwinded (Cic.Meta (i,identity_relocation_list))
- in
- subst',metasenv'
- ) ([],metasenv) subst
-;;
+ | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
+ | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
+ if UriManager.eq uri1 uri2 then
+ fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
+ exp_named_subst1 exp_named_subst2
+ else
+ raise (UnificationFailure "3")
+ (* (sprintf
+ "Can't unify %s with %s due to different constants"
+ (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2))) *)
+ | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
+ if UriManager.eq uri1 uri2 && i1 = i2 then
+ fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
+ exp_named_subst1 exp_named_subst2
+ else
+ raise (UnificationFailure "4")
+ (* (sprintf
+ "Can't unify %s with %s due to different inductive principles"
+ (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2))) *)
+ | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
+ C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
+ if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
+ fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
+ exp_named_subst1 exp_named_subst2
+ else
+ raise (UnificationFailure "5")
+ (* (sprintf
+ "Can't unify %s with %s due to different inductive constructors"
+ (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2))) *)
+ | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
+ | (C.Cast (te,ty), t2) -> fo_unif_subst test_equality_only
+ subst context metasenv te t2
+ | (t1, C.Cast (te,ty)) -> fo_unif_subst test_equality_only
+ subst context metasenv t1 te
+ | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
+ (* TASSI: this is the only case in which we want == *)
+ let subst',metasenv' = fo_unif_subst true
+ subst context metasenv s1 s2 in
+ fo_unif_subst test_equality_only
+ subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
+ | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
+ (* TASSI: ask someone a reason for not putting true here *)
+ let subst',metasenv' = fo_unif_subst test_equality_only
+ subst context metasenv s1 s2 in
+ fo_unif_subst test_equality_only
+ subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
+ | (C.LetIn (_,s1,t1), t2)
+ | (t2, C.LetIn (_,s1,t1)) ->
+ fo_unif_subst
+ test_equality_only subst context metasenv t2 (S.subst s1 t1)
+ | (C.Appl l1, C.Appl l2) ->
+ (* andrea: this case should be probably rewritten in the
+ spirit of deref *)
+ let rec beta_reduce =
+ function
+ (Cic.Appl (Cic.Lambda (_,_,t)::he'::tl')) ->
+ let he'' = CicSubstitution.subst he' t in
+ if tl' = [] then
+ he''
+ else
+ beta_reduce (Cic.Appl(he''::tl'))
+ | t -> t in
+ (match l1,l2 with
+ C.Meta (i,_)::args1, C.Meta (j,_)::args2 when i = j ->
+ (try
+ List.fold_left2
+ (fun (subst,metasenv) ->
+ fo_unif_subst test_equality_only subst context metasenv)
+ (subst,metasenv) l1 l2
+ with (Invalid_argument msg) -> raise (UnificationFailure msg))
+ | C.Meta (i,l)::args, _ ->
+ (try
+ let (_,t) = CicUtil.lookup_subst i subst in
+ let lifted = S.lift_meta l t in
+ let reduced = beta_reduce (Cic.Appl (lifted::args)) in
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv reduced t2
+ with CicUtil.Subst_not_found _ ->
+ let subst,metasenv,beta_expanded =
+ beta_expand_many
+ test_equality_only metasenv subst context t2 args in
+ fo_unif_subst test_equality_only subst context metasenv
+ (C.Meta (i,l)) beta_expanded)
+ | _, C.Meta (i,l)::args ->
+ (try
+ let (_,t) = CicUtil.lookup_subst i subst in
+ let lifted = S.lift_meta l t in
+ let reduced = beta_reduce (Cic.Appl (lifted::args)) in
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv t1 reduced
+ with CicUtil.Subst_not_found _ ->
+ let subst,metasenv,beta_expanded =
+ beta_expand_many
+ test_equality_only metasenv subst context t1 args in
+ fo_unif_subst test_equality_only subst context metasenv
+ (C.Meta (i,l)) beta_expanded)
+ | _,_ ->
+ let lr1 = List.rev l1 in
+ let lr2 = List.rev l2 in
+ let rec fo_unif_l test_equality_only subst metasenv =
+ function
+ [],_
+ | _,[] -> assert false
+ | ([h1],[h2]) ->
+ fo_unif_subst test_equality_only subst context metasenv h1 h2
+ | ([h],l)
+ | (l,[h]) ->
+ fo_unif_subst test_equality_only subst context metasenv
+ h (C.Appl (List.rev l))
+ | ((h1::l1),(h2::l2)) ->
+ let subst', metasenv' =
+ fo_unif_subst test_equality_only subst context metasenv h1 h2
+ in
+ fo_unif_l test_equality_only subst' metasenv' (l1,l2)
+ in
+ fo_unif_l test_equality_only subst metasenv (lr1, lr2) )
+ | (C.MutCase (_,_,outt1,t1',pl1), C.MutCase (_,_,outt2,t2',pl2))->
+ let subst', metasenv' =
+ fo_unif_subst test_equality_only subst context metasenv outt1 outt2 in
+ let subst'',metasenv'' =
+ fo_unif_subst test_equality_only subst' context metasenv' t1' t2' in
+ (try
+ List.fold_left2
+ (function (subst,metasenv) ->
+ fo_unif_subst test_equality_only subst context metasenv
+ ) (subst'',metasenv'') pl1 pl2
+ with
+ Invalid_argument _ ->
+ raise (UnificationFailure "6"))
+ (* (sprintf
+ "Error trying to unify %s with %s: the number of branches is not the same." (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2)))) *)
+ | (C.Rel _, _) | (_, C.Rel _) ->
+ if t1 = t2 then
+ subst, metasenv
+ else
+ raise (UnificationFailure "6")
+ (* (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2))) *)
+ | (C.Sort _ ,_) | (_, C.Sort _)
+ | (C.Const _, _) | (_, C.Const _)
+ | (C.MutInd _, _) | (_, C.MutInd _)
+ | (C.MutConstruct _, _) | (_, C.MutConstruct _)
+ | (C.Fix _, _) | (_, C.Fix _)
+ | (C.CoFix _, _) | (_, C.CoFix _) ->
+ if t1 = t2 || R.are_convertible ~subst ~metasenv context t1 t2 then
+ subst, metasenv
+ else
+ raise (UnificationFailure "7")
+ (* (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2))) *)
+ | (_,_) ->
+ if R.are_convertible ~subst ~metasenv context t1 t2 then
+ subst, metasenv
+ else
+ raise (UnificationFailure "8")
+ (* (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1) (CicMetaSubst.ppterm subst t2))) *)