1 (* Copyright (C) 2000, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
28 exception AssertFailure of string;;
29 exception UnificationFailure of string;;
31 let debug_print = prerr_endline
33 let type_of_aux' metasenv subst context term =
35 CicMetaSubst.type_of_aux' metasenv subst context term
36 with CicMetaSubst.MetaSubstFailure msg ->
39 "Type checking error: %s in context\n%s.\nException: %s.\nBroken invariant: unification must be invoked only on well typed terms"
40 (CicPp.ppterm (CicMetaSubst.apply_subst subst term))
41 (CicMetaSubst.ppcontext subst context) msg)))
43 (* NUOVA UNIFICAZIONE *)
44 (* A substitution is a (int * Cic.term) list that associates a
45 metavariable i with its body.
46 A metaenv is a (int * Cic.term) list that associate a metavariable
48 fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back
49 a new substitution which is _NOT_ unwinded. It must be unwinded before
52 let rec fo_unif_subst subst context metasenv t1 t2 =
54 let module R = CicMetaSubst in
55 let module S = CicSubstitution in
57 (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
65 | Some t1', Some t2' ->
66 (* First possibility: restriction *)
67 (* Second possibility: unification *)
68 (* Third possibility: convertibility *)
69 R.are_convertible metasenv subst context t1' t2'
75 raise (UnificationFailure (sprintf
76 "Error trying to unify %s with %s: the algorithm only tried to check convertibility of the two substitutions"
77 (CicPp.ppterm t1) (CicPp.ppterm t2)))
78 | (C.Meta (n,l), C.Meta (m,_)) when n>m ->
79 fo_unif_subst subst context metasenv t2 t1
81 | (t, C.Meta (n,l)) ->
82 let subst',metasenv' =
84 let oldt = (List.assoc n subst) in
85 let lifted_oldt = S.lift_meta l oldt in
86 fo_unif_subst subst context metasenv lifted_oldt t
88 let t',metasenv' = CicMetaSubst.delift n subst context metasenv l t in
89 (n, t')::subst, metasenv'
91 let (_,_,meta_type) = CicUtil.lookup_meta n metasenv' in
92 let tyt = type_of_aux' metasenv' subst' context t in
93 fo_unif_subst subst' context metasenv' (S.lift_meta l meta_type) tyt
94 | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
95 | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
96 if UriManager.eq uri1 uri2 then
97 fo_unif_subst_exp_named_subst subst context metasenv
98 exp_named_subst1 exp_named_subst2
100 raise (UnificationFailure (sprintf
101 "Can't unify %s with %s due to different constants"
102 (CicPp.ppterm t1) (CicPp.ppterm t1)))
103 | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
104 if UriManager.eq uri1 uri2 && i1 = i2 then
105 fo_unif_subst_exp_named_subst subst context metasenv
106 exp_named_subst1 exp_named_subst2
108 raise (UnificationFailure (sprintf
109 "Can't unify %s with %s due to different inductive principles"
110 (CicPp.ppterm t1) (CicPp.ppterm t1)))
111 | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
112 C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
113 if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
114 fo_unif_subst_exp_named_subst subst context metasenv
115 exp_named_subst1 exp_named_subst2
117 raise (UnificationFailure (sprintf
118 "Can't unify %s with %s due to different inductive constructors"
119 (CicPp.ppterm t1) (CicPp.ppterm t1)))
120 | (C.Implicit, _) | (_, C.Implicit) -> assert false
121 | (C.Cast (te,ty), t2) -> fo_unif_subst subst context metasenv te t2
122 | (t1, C.Cast (te,ty)) -> fo_unif_subst subst context metasenv t1 te
123 | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
124 let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
125 fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
126 | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
127 let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
128 fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
129 | (C.LetIn (_,s1,t1), t2)
130 | (t2, C.LetIn (_,s1,t1)) ->
131 fo_unif_subst subst context metasenv t2 (S.subst s1 t1)
132 | (C.Appl l1, C.Appl l2) ->
133 let lr1 = List.rev l1 in
134 let lr2 = List.rev l2 in
135 let rec fo_unif_l subst metasenv =
138 | _,[] -> assert false
140 fo_unif_subst subst context metasenv h1 h2
143 fo_unif_subst subst context metasenv h (C.Appl (List.rev l))
144 | ((h1::l1),(h2::l2)) ->
145 let subst', metasenv' =
146 fo_unif_subst subst context metasenv h1 h2
148 fo_unif_l subst' metasenv' (l1,l2)
150 fo_unif_l subst metasenv (lr1, lr2)
151 | (C.MutCase (_,_,outt1,t1,pl1), C.MutCase (_,_,outt2,t2,pl2))->
152 let subst', metasenv' =
153 fo_unif_subst subst context metasenv outt1 outt2 in
154 let subst'',metasenv'' =
155 fo_unif_subst subst' context metasenv' t1 t2 in
157 (function (subst,metasenv) ->
158 fo_unif_subst subst context metasenv
159 ) (subst'',metasenv'') pl1 pl2
160 | (C.Rel _, _) | (_, C.Rel _)
161 | (C.Sort _ ,_) | (_, C.Sort _)
162 | (C.Const _, _) | (_, C.Const _)
163 | (C.MutInd _, _) | (_, C.MutInd _)
164 | (C.MutConstruct _, _) | (_, C.MutConstruct _)
165 | (C.Fix _, _) | (_, C.Fix _)
166 | (C.CoFix _, _) | (_, C.CoFix _) ->
167 if R.are_convertible metasenv subst context t1 t2 then
170 raise (UnificationFailure (sprintf
171 "Can't unify %s with %s because they are not convertible"
172 (CicPp.ppterm t1) (CicPp.ppterm t2)))
174 if R.are_convertible metasenv subst context t1 t2 then
177 raise (UnificationFailure (sprintf
178 "Can't unify %s with %s because they are not convertible"
179 (CicPp.ppterm t1) (CicPp.ppterm t2)))
181 and fo_unif_subst_exp_named_subst subst context metasenv
182 exp_named_subst1 exp_named_subst2
186 (fun (subst,metasenv) (uri1,t1) (uri2,t2) ->
188 fo_unif_subst subst context metasenv t1 t2
189 ) (subst,metasenv) exp_named_subst1 exp_named_subst2
192 let uri = UriManager.uri_of_string "cic:/dummy.var" in
193 debug_print ("@@@: " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst1)) ^
194 " <==> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst2))) ; raise e
196 (* A substitution is a (int * Cic.term) list that associates a *)
197 (* metavariable i with its body. *)
198 (* metasenv is of type Cic.metasenv *)
199 (* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back *)
200 (* a new substitution which is already unwinded and ready to be applied and *)
201 (* a new metasenv in which some hypothesis in the contexts of the *)
202 (* metavariables may have been restricted. *)
203 let fo_unif metasenv context t1 t2 =
204 let subst_to_unwind,metasenv' = fo_unif_subst [] context metasenv t1 t2 in
205 CicMetaSubst.unwind_subst metasenv' subst_to_unwind
208 let fo_unif_subst subst context metasenv t1 t2 =
210 sprintf "Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nbecause %s"
211 (CicPp.ppterm (CicMetaSubst.apply_subst subst t1))
213 CicPp.ppterm (type_of_aux' metasenv subst context t1)
214 with _ -> "MALFORMED")
215 (CicPp.ppterm (CicMetaSubst.apply_subst subst t2))
217 CicPp.ppterm (type_of_aux' metasenv subst context t2)
218 with _ -> "MALFORMED")
219 (CicMetaSubst.ppcontext subst context)
220 (CicMetaSubst.ppmetasenv subst metasenv) msg
223 fo_unif_subst subst context metasenv t1 t2
225 | AssertFailure msg -> raise (AssertFailure (enrich_msg msg))
226 | UnificationFailure msg -> raise (UnificationFailure (enrich_msg msg))