* debian/rules: instead of passing explicit -I flags to ocamldoc, do them

[helm.git] / helm / software / components / cic_unification / cicRefine.ml

diff --git a/helm/software/components/cic_unification/cicRefine.ml b/helm/software/components/cic_unification/cicRefine.ml
index 49c85a72eea1b0fc09efb2d805f988040f12d4e4..954c4835bcd05b3d7a126ed7483656f0bcdc08bc 100644 (file)
--- a/helm/software/components/cic_unification/cicRefine.ml
+++ b/helm/software/components/cic_unification/cicRefine.ml
@@ -568,7 +568,7 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
              exn ->
               enrich localization_tbl term' exn
                ~f:(function _ ->
-                 lazy ("(10)The term " ^
+                 lazy ("The term " ^
                   CicMetaSubst.ppterm_in_context ~metasenv subst term'
                    context ^ " has type " ^
                   CicMetaSubst.ppterm_in_context ~metasenv subst actual_type
@@ -613,7 +613,7 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
                     exn ->
                      enrich localization_tbl constructor'
                       ~f:(fun _ ->
-                        lazy ("(11)The term " ^
+                        lazy ("The term " ^
                          CicMetaSubst.ppterm_in_context metasenv subst p'
                           context ^ " has type " ^
                          CicMetaSubst.ppterm_in_context metasenv subst actual_type
@@ -800,7 +800,7 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
                       exn ->
                        enrich localization_tbl p exn
                         ~f:(function _ ->
-                          lazy ("(12)The term " ^
+                          lazy ("The term " ^
                            CicMetaSubst.ppterm_in_context ~metasenv subst p
                             context ^ " has type " ^
                            CicMetaSubst.ppterm_in_context ~metasenv subst instance'
@@ -841,7 +841,7 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
                      exn ->
                       enrich localization_tbl bo exn
                        ~f:(function _ ->
-                         lazy ("(13)The term " ^
+                         lazy ("The term " ^
                           CicMetaSubst.ppterm_in_context ~metasenv subst bo
                            context' ^ " has type " ^
                           CicMetaSubst.ppterm_in_context ~metasenv subst ty_of_bo
@@ -894,7 +894,7 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
                      exn ->
                       enrich localization_tbl bo exn
                        ~f:(function _ ->
-                         lazy ("(14)The term " ^
+                         lazy ("The term " ^
                           CicMetaSubst.ppterm_in_context ~metasenv subst bo
                            context' ^ " has type " ^
                           CicMetaSubst.ppterm_in_context ~metasenv subst ty_of_bo
@@ -1204,14 +1204,16 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
             (fun (metasenv,last,coerc) -> 
               let pp t = 
                 CicMetaSubst.ppterm_in_context ~metasenv subst t context in
-              let subst,metasenv,ugraph =
-               fo_unif_subst subst context metasenv last he ugraph in
-              debug_print (lazy ("New head: "^ pp coerc));
               try
+               let subst,metasenv,ugraph =
+                fo_unif_subst subst context metasenv last he ugraph in
+                debug_print (lazy ("New head: "^ pp coerc));
                 let tty,ugraph =
-                 CicTypeChecker.type_of_aux' ~subst metasenv context coerc ugraph in 
-                debug_print (lazy (" has type: "^ pp tty));
-                Some (coerc,tty,subst,metasenv,ugraph)
+                 CicTypeChecker.type_of_aux' ~subst metasenv context coerc
+                  ugraph
+                in 
+                 debug_print (lazy (" has type: "^ pp tty));
+                 Some (coerc,tty,subst,metasenv,ugraph)
               with
               | Uncertain _ | RefineFailure _
               | HExtlib.Localized (_,Uncertain _)
@@ -1373,10 +1375,8 @@ and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
           fo_unif_subst subst context metasenv infty expty ugraph
         in
         (t, expty), subst, metasenv, ugraph
-      with Uncertain _ | RefineFailure _ as exn ->
-        if not allow_coercions || not !insert_coercions then
-          enrich localization_tbl t exn
-        else
+      with (Uncertain _ | RefineFailure _ as exn)
+        when allow_coercions && !insert_coercions ->
           let whd = CicReduction.whd ~delta:false in
           let clean t s c = whd c (CicMetaSubst.apply_subst s t) in
           let infty = clean infty subst context in
@@ -1829,11 +1829,41 @@ let typecheck metasenv uri obj ~localization_tbl =
  let ugraph = CicUniv.empty_ugraph in
  match obj with
     Cic.Constant (name,Some bo,ty,args,attrs) ->
+     (* CSC: ugly code. Here I need to retrieve in advance the loc of bo
+        since type_of_aux' destroys localization information (which are
+        preserved by type_of_aux *)
+     let loc exn' =
+      try
+       Cic.CicHash.find localization_tbl bo
+      with Not_found ->
+       HLog.debug ("!!! NOT LOCALIZED: " ^ CicPp.ppterm bo);
+       raise exn' in
      let bo',boty,metasenv,ugraph =
       type_of_aux' ~localization_tbl metasenv [] bo ugraph in
      let ty',_,metasenv,ugraph =
       type_of_aux' ~localization_tbl metasenv [] ty ugraph in
-     let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in
+     let subst,metasenv,ugraph =
+      try
+       fo_unif_subst [] [] metasenv boty ty' ugraph
+      with
+         RefineFailure _
+       | Uncertain _ as exn ->
+          let msg = 
+            lazy ("The term " ^
+             CicMetaSubst.ppterm_in_context ~metasenv [] bo' [] ^
+             " has type " ^
+             CicMetaSubst.ppterm_in_context ~metasenv [] boty [] ^
+             " but is here used with type " ^
+             CicMetaSubst.ppterm_in_context ~metasenv [] ty' [])
+          in
+           let exn' =
+            match exn with
+               RefineFailure _ -> RefineFailure msg
+             | Uncertain _ -> Uncertain msg
+             | _ -> assert false
+           in
+            raise (HExtlib.Localized (loc exn',exn'))
+     in
      let bo' = CicMetaSubst.apply_subst subst bo' in
      let ty' = CicMetaSubst.apply_subst subst ty' in
      let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in