]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/cic_unification/cicUnification.ml
fixed typo
[helm.git] / helm / ocaml / cic_unification / cicUnification.ml
1 (* Copyright (C) 2000, HELM Team.
2  * 
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.
6  * 
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.
11  * 
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.
16  *
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,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26 open Printf
27
28 exception UnificationFailure of string;;
29 exception Uncertain of string;;
30 exception AssertFailure of string;;
31
32 let debug_print = prerr_endline
33
34 let type_of_aux' metasenv subst context term =
35   try
36     CicMetaSubst.type_of_aux' metasenv subst context term
37   with
38   | CicMetaSubst.MetaSubstFailure msg ->
39     raise (AssertFailure
40       ((sprintf
41         "Type checking error: %s in context\n%s\nand metasenv\n%s.\nException: %s.\nBroken invariant: unification must be invoked only on well typed terms"
42         (CicMetaSubst.ppterm subst term)
43         (CicMetaSubst.ppcontext subst context)
44         (CicMetaSubst.ppmetasenv metasenv subst) msg)))
45
46 (* NUOVA UNIFICAZIONE *)
47 (* A substitution is a (int * Cic.term) list that associates a
48    metavariable i with its body.
49    A metaenv is a (int * Cic.term) list that associate a metavariable
50    i with is type. 
51    fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back
52    a new substitution which is _NOT_ unwinded. It must be unwinded before
53    applying it. *)
54
55 let rec fo_unif_subst subst context metasenv t1 t2 =  
56  let module C = Cic in
57  let module R = CicMetaSubst in
58  let module S = CicSubstitution in
59   match (t1, t2) with
60      (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
61        let ok,subst,metasenv =
62         List.fold_left2
63          (fun (b,subst,metasenv) t1 t2 ->
64            if b then true,subst,metasenv else
65             match t1,t2 with
66                None,_
67              | _,None -> true,subst,metasenv
68              | Some t1', Some t2' ->
69                 (* First possibility:  restriction    *)
70                 (* Second possibility: unification    *)
71                 (* Third possibility:  convertibility *)
72                 if R.are_convertible subst context t1' t2' then
73                  true,subst,metasenv
74                 else
75                  (try
76                    let subst,metasenv =
77                     fo_unif_subst subst context metasenv t1' t2'
78                    in
79                     true,subst,metasenv
80                  with
81                   Not_found -> false,subst,metasenv)
82          ) (true,subst,metasenv) ln lm
83        in
84         if ok then
85           subst,metasenv
86         else
87           raise (UnificationFailure (sprintf
88             "Error trying to unify %s with %s: the algorithm tried to check whether the two substitutions are convertible; if they are not, it tried to unify the two substitutions. No restriction was attempted."
89             (CicPp.ppterm t1) (CicPp.ppterm t2)))
90    | (C.Meta (n,l), C.Meta (m,_)) when n>m ->
91        fo_unif_subst subst context metasenv t2 t1
92    | (C.Meta (n,l), t)   
93    | (t, C.Meta (n,l)) ->
94        let subst'',metasenv' =
95         try
96          let oldt = (List.assoc n subst) in
97          let lifted_oldt = S.lift_meta l oldt in
98           fo_unif_subst subst context metasenv lifted_oldt t
99         with Not_found ->
100          let t',metasenv',subst' =
101           try
102            CicMetaSubst.delift n subst context metasenv l t
103           with
104              (CicMetaSubst.MetaSubstFailure msg)-> raise(UnificationFailure msg)
105            | (CicMetaSubst.Uncertain msg) -> raise (Uncertain msg)
106          in
107           (n, t')::subst', metasenv'
108        in
109         let (_,_,meta_type) =  CicUtil.lookup_meta n metasenv' in
110         (try
111           let tyt =
112             type_of_aux' metasenv' subst'' context t
113           in
114            fo_unif_subst subst'' context metasenv' (S.lift_meta l meta_type) tyt
115         with AssertFailure _ ->
116           (* TODO huge hack!!!!
117            * we keep on unifying/refining in the hope that the problem will be
118            * eventually solved. In the meantime we're breaking a big invariant:
119            * the terms that we are unifying are no longer well typed in the
120            * current context (in the worst case we could even diverge)
121            *)
122 (*
123 prerr_endline "********* FROM NOW ON EVERY REASONABLE INVARIANT IS BROKEN.";
124 prerr_endline "********* PROCEED AT YOUR OWN RISK. AND GOOD LUCK." ;
125 *)
126           (subst'', metasenv'))
127    | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
128    | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
129       if UriManager.eq uri1 uri2 then
130        fo_unif_subst_exp_named_subst subst context metasenv
131         exp_named_subst1 exp_named_subst2
132       else
133        raise (UnificationFailure (sprintf
134         "Can't unify %s with %s due to different constants"
135         (CicPp.ppterm t1) (CicPp.ppterm t2)))
136    | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
137       if UriManager.eq uri1 uri2 && i1 = i2 then
138        fo_unif_subst_exp_named_subst subst context metasenv
139         exp_named_subst1 exp_named_subst2
140       else
141        raise (UnificationFailure (sprintf
142         "Can't unify %s with %s due to different inductive principles"
143         (CicPp.ppterm t1) (CicPp.ppterm t1)))
144    | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
145      C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
146       if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
147        fo_unif_subst_exp_named_subst subst context metasenv
148         exp_named_subst1 exp_named_subst2
149       else
150        raise (UnificationFailure (sprintf
151         "Can't unify %s with %s due to different inductive constructors"
152         (CicPp.ppterm t1) (CicPp.ppterm t1)))
153    | (C.Implicit _, _) | (_, C.Implicit _) ->  assert false
154    | (C.Cast (te,ty), t2) -> fo_unif_subst subst context metasenv te t2
155    | (t1, C.Cast (te,ty)) -> fo_unif_subst subst context metasenv t1 te
156    | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) -> 
157        let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
158         fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
159    | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) -> 
160        let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
161         fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
162    | (C.LetIn (_,s1,t1), t2)  
163    | (t2, C.LetIn (_,s1,t1)) -> 
164        fo_unif_subst subst context metasenv t2 (S.subst s1 t1)
165    | (C.Appl l1, C.Appl l2) -> 
166        let lr1 = List.rev l1 in
167        let lr2 = List.rev l2 in
168        let rec fo_unif_l subst metasenv =
169         function
170            [],_
171          | _,[] -> assert false
172          | ([h1],[h2]) ->
173              fo_unif_subst subst context metasenv h1 h2
174          | ([h],l) 
175          | (l,[h]) ->
176              fo_unif_subst subst context metasenv h (C.Appl (List.rev l))
177          | ((h1::l1),(h2::l2)) -> 
178             let subst', metasenv' = 
179              fo_unif_subst subst context metasenv h1 h2
180             in 
181              fo_unif_l subst' metasenv' (l1,l2)
182        in
183         fo_unif_l subst metasenv (lr1, lr2) 
184    | (C.MutCase (_,_,outt1,t1,pl1), C.MutCase (_,_,outt2,t2,pl2))->
185        let subst', metasenv' = 
186         fo_unif_subst subst context metasenv outt1 outt2 in
187        let subst'',metasenv'' = 
188         fo_unif_subst subst' context metasenv' t1 t2 in
189        List.fold_left2 
190         (function (subst,metasenv) ->
191           fo_unif_subst subst context metasenv
192         ) (subst'',metasenv'') pl1 pl2 
193    | (C.Rel _, _) | (_,  C.Rel _)
194    | (C.Sort _ ,_) | (_, C.Sort _)
195    | (C.Const _, _) | (_, C.Const _)
196    | (C.MutInd  _, _) | (_, C.MutInd _)
197    | (C.MutConstruct _, _) | (_, C.MutConstruct _)
198    | (C.Fix _, _) | (_, C.Fix _) 
199    | (C.CoFix _, _) | (_, C.CoFix _) -> 
200        if R.are_convertible subst context t1 t2 then
201         subst, metasenv
202        else
203         raise (UnificationFailure (sprintf
204           "Can't unify %s with %s because they are not convertible"
205           (CicPp.ppterm t1) (CicPp.ppterm t2)))
206    | (_,_) ->
207        if R.are_convertible subst context t1 t2 then
208         subst, metasenv
209        else
210         raise (UnificationFailure (sprintf
211           "Can't unify %s with %s because they are not convertible"
212           (CicPp.ppterm t1) (CicPp.ppterm t2)))
213
214 and fo_unif_subst_exp_named_subst subst context metasenv
215  exp_named_subst1 exp_named_subst2
216 =
217 try
218  List.fold_left2
219   (fun (subst,metasenv) (uri1,t1) (uri2,t2) ->
220     assert (uri1=uri2) ;
221     fo_unif_subst subst context metasenv t1 t2
222   ) (subst,metasenv) exp_named_subst1 exp_named_subst2
223 with
224 e ->
225 let uri = UriManager.uri_of_string "cic:/dummy.var" in
226 debug_print ("@@@: " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst1)) ^
227 " <==> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst2))) ; raise e
228
229 (* A substitution is a (int * Cic.term) list that associates a               *)
230 (* metavariable i with its body.                                             *)
231 (* metasenv is of type Cic.metasenv                                          *)
232 (* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back   *)
233 (* a new substitution which is already unwinded and ready to be applied and  *)
234 (* a new metasenv in which some hypothesis in the contexts of the            *)
235 (* metavariables may have been restricted.                                   *)
236 let fo_unif metasenv context t1 t2 = fo_unif_subst [] context metasenv t1 t2 ;;
237
238 let fo_unif_subst subst context metasenv t1 t2 =
239   let enrich_msg msg =
240     sprintf "Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nbecause %s"
241       (CicMetaSubst.ppterm subst t1)
242       (try
243         CicPp.ppterm (type_of_aux' metasenv subst context t1)
244       with _ -> "MALFORMED")
245       (CicMetaSubst.ppterm subst t2)
246       (try
247         CicPp.ppterm (type_of_aux' metasenv subst context t2)
248       with _ -> "MALFORMED")
249       (CicMetaSubst.ppcontext subst context)
250       (CicMetaSubst.ppmetasenv metasenv subst) msg
251   in
252   try
253     fo_unif_subst subst context metasenv t1 t2
254   with
255   | AssertFailure msg -> raise (AssertFailure (enrich_msg msg))
256   | UnificationFailure msg -> raise (UnificationFailure (enrich_msg msg))
257 ;;
258