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