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 AssertFailure of string;;
  29 exception UnificationFailure of string;;
  30
  31 let debug_print = prerr_endline
  32
  33 let type_of_aux' metasenv subst context term =
  34   try
  35     CicMetaSubst.type_of_aux' metasenv subst context term
  36   with CicMetaSubst.MetaSubstFailure msg ->
  37     raise (AssertFailure
  38       ((sprintf
  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)))
  42
  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
  47    i with is type.
  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
  50    applying it. *)
  51
  52 let rec fo_unif_subst subst context metasenv t1 t2 =
  53  let module C = Cic in
  54  let module R = CicMetaSubst in
  55  let module S = CicSubstitution in
  56   match (t1, t2) with
  57      (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
  58        let ok =
  59         List.fold_left2
  60          (fun b t1 t2 ->
  61            b &&
  62             match t1,t2 with
  63                None,_
  64              | _,None -> true
  65              | Some t1', Some t2' ->
  66                 (* First possibility:  restriction    *)
  67                 (* Second possibility: unification    *)
  68                 (* Third possibility:  convertibility *)
  69                 R.are_convertible subst context t1' t2'
  70          ) true ln lm
  71        in
  72         if ok then
  73           subst,metasenv
  74         else
  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
  80    | (C.Meta (n,l), t)
  81    | (t, C.Meta (n,l)) ->
  82        let subst',metasenv' =
  83         try
  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
  87         with Not_found ->
  88          let t',metasenv' = CicMetaSubst.delift context metasenv l t in
  89           (n, t')::subst, metasenv'
  90        in
  91         let (_,_,meta_type) =
  92          List.find (function (m,_,_) -> m=n) metasenv' in
  93         let tyt = type_of_aux' metasenv' subst' context t in
  94          fo_unif_subst subst' context metasenv' (S.lift_meta l meta_type) tyt
  95    | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
  96    | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
  97       if UriManager.eq uri1 uri2 then
  98        fo_unif_subst_exp_named_subst subst context metasenv
  99         exp_named_subst1 exp_named_subst2
 100       else
 101        raise (UnificationFailure (sprintf
 102         "Can't unify %s with %s due to different constants"
 103         (CicPp.ppterm t1) (CicPp.ppterm t1)))
 104    | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
 105       if UriManager.eq uri1 uri2 && i1 = i2 then
 106        fo_unif_subst_exp_named_subst subst context metasenv
 107         exp_named_subst1 exp_named_subst2
 108       else
 109        raise (UnificationFailure (sprintf
 110         "Can't unify %s with %s due to different inductive principles"
 111         (CicPp.ppterm t1) (CicPp.ppterm t1)))
 112    | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
 113      C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
 114       if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
 115        fo_unif_subst_exp_named_subst subst context metasenv
 116         exp_named_subst1 exp_named_subst2
 117       else
 118        raise (UnificationFailure (sprintf
 119         "Can't unify %s with %s due to different inductive constructors"
 120         (CicPp.ppterm t1) (CicPp.ppterm t1)))
 121    | (C.Implicit, _) | (_, C.Implicit) ->  assert false
 122    | (C.Cast (te,ty), t2) -> fo_unif_subst subst context metasenv te t2
 123    | (t1, C.Cast (te,ty)) -> fo_unif_subst subst context metasenv t1 te
 124    | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
 125        let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
 126         fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
 127    | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
 128        let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
 129         fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
 130    | (C.LetIn (_,s1,t1), t2)
 131    | (t2, C.LetIn (_,s1,t1)) ->
 132        fo_unif_subst subst context metasenv t2 (S.subst s1 t1)
 133    | (C.Appl l1, C.Appl l2) ->
 134        let lr1 = List.rev l1 in
 135        let lr2 = List.rev l2 in
 136        let rec fo_unif_l subst metasenv =
 137         function
 138            [],_
 139          | _,[] -> assert false
 140          | ([h1],[h2]) ->
 141              fo_unif_subst subst context metasenv h1 h2
 142          | ([h],l)
 143          | (l,[h]) ->
 144              fo_unif_subst subst context metasenv h (C.Appl (List.rev l))
 145          | ((h1::l1),(h2::l2)) ->
 146             let subst', metasenv' =
 147              fo_unif_subst subst context metasenv h1 h2
 148             in
 149              fo_unif_l subst' metasenv' (l1,l2)
 150        in
 151         fo_unif_l subst metasenv (lr1, lr2)
 152    | (C.MutCase (_,_,outt1,t1,pl1), C.MutCase (_,_,outt2,t2,pl2))->
 153        let subst', metasenv' =
 154         fo_unif_subst subst context metasenv outt1 outt2 in
 155        let subst'',metasenv'' =
 156         fo_unif_subst subst' context metasenv' t1 t2 in
 157        List.fold_left2
 158         (function (subst,metasenv) ->
 159           fo_unif_subst subst context metasenv
 160         ) (subst'',metasenv'') pl1 pl2
 161    | (C.Rel _, _) | (_,  C.Rel _)
 162    | (C.Sort _ ,_) | (_, C.Sort _)
 163    | (C.Const _, _) | (_, C.Const _)
 164    | (C.MutInd  _, _) | (_, C.MutInd _)
 165    | (C.MutConstruct _, _) | (_, C.MutConstruct _)
 166    | (C.Fix _, _) | (_, C.Fix _)
 167    | (C.CoFix _, _) | (_, C.CoFix _) ->
 168        if R.are_convertible subst context t1 t2 then
 169         subst, metasenv
 170        else
 171         raise (UnificationFailure (sprintf
 172           "Can't unify %s with %s because they are not convertible"
 173           (CicPp.ppterm t1) (CicPp.ppterm t2)))
 174    | (_,_) ->
 175        if R.are_convertible subst context t1 t2 then
 176         subst, metasenv
 177        else
 178         raise (UnificationFailure (sprintf
 179           "Can't unify %s with %s because they are not convertible"
 180           (CicPp.ppterm t1) (CicPp.ppterm t2)))
 181
 182 and fo_unif_subst_exp_named_subst subst context metasenv
 183  exp_named_subst1 exp_named_subst2
 184 =
 185 try
 186  List.fold_left2
 187   (fun (subst,metasenv) (uri1,t1) (uri2,t2) ->
 188     assert (uri1=uri2) ;
 189     fo_unif_subst subst context metasenv t1 t2
 190   ) (subst,metasenv) exp_named_subst1 exp_named_subst2
 191 with
 192 e ->
 193 let uri = UriManager.uri_of_string "cic:/dummy.var" in
 194 debug_print ("@@@: " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst1)) ^
 195 " <==> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst2))) ; raise e
 196
 197 (* A substitution is a (int * Cic.term) list that associates a               *)
 198 (* metavariable i with its body.                                             *)
 199 (* metasenv is of type Cic.metasenv                                          *)
 200 (* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back   *)
 201 (* a new substitution which is already unwinded and ready to be applied and  *)
 202 (* a new metasenv in which some hypothesis in the contexts of the            *)
 203 (* metavariables may have been restricted.                                   *)
 204 let fo_unif metasenv context t1 t2 =
 205  let subst_to_unwind,metasenv' = fo_unif_subst [] context metasenv t1 t2 in
 206   CicMetaSubst.unwind_subst metasenv' subst_to_unwind
 207 ;;
 208
 209 let fo_unif_subst subst context metasenv t1 t2 =
 210   let enrich_msg msg =
 211     sprintf "Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nbecause %s"
 212       (CicPp.ppterm (CicMetaSubst.apply_subst subst t1))
 213       (try
 214         CicPp.ppterm (type_of_aux' metasenv subst context t1)
 215       with _ -> "MALFORMED")
 216       (CicPp.ppterm (CicMetaSubst.apply_subst subst t2))
 217       (try
 218         CicPp.ppterm (type_of_aux' metasenv subst context t2)
 219       with _ -> "MALFORMED")
 220       (CicMetaSubst.ppcontext subst context)
 221       (CicMetaSubst.ppmetasenv subst metasenv) msg
 222   in
 223   try
 224     fo_unif_subst subst context metasenv t1 t2
 225   with
 226   | AssertFailure msg -> raise (AssertFailure (enrich_msg msg))
 227   | UnificationFailure msg -> raise (UnificationFailure (enrich_msg msg))
 228 ;;
 229