An unimplemented case of clearbody is now implemented.

[helm.git] / helm / software / components / tactics / proofEngineStructuralRules.ml

diff --git a/helm/software/components/tactics/proofEngineStructuralRules.ml b/helm/software/components/tactics/proofEngineStructuralRules.ml
index acc4bb1640ac112819ff403e2728d34f3ffe864f..755fab66051ee59197b081e85c3bdba20fdf04aa 100644 (file)
--- a/helm/software/components/tactics/proofEngineStructuralRules.ml
+++ b/helm/software/components/tactics/proofEngineStructuralRules.ml
@@ -30,7 +30,7 @@ module C = Cic
 
 let clearbody ~hyp = 
  let clearbody (proof, goal) =
-   let curi,metasenv,pbo,pty = proof in
+   let curi,metasenv,_subst,pbo,pty, attrs = proof in
     let metano,_,_ = CicUtil.lookup_meta goal metasenv in
      let string_of_name =
       function
@@ -75,7 +75,23 @@ let clearbody ~hyp =
                           ))
                      in
                       entry::context
-                  | Some (_,Cic.Def (_,Some _)) -> assert false
+                  | Some (n,Cic.Def (te,Some ty)) ->
+                     (try
+                       ignore
+                        (CicTypeChecker.type_of_aux' metasenv context te
+                          CicUniv.empty_ugraph (* TASSI: FIXME *));
+                       ignore
+                        (CicTypeChecker.type_of_aux' metasenv context ty
+                          CicUniv.empty_ugraph (* TASSI: FIXME *));
+                      with
+                       _ ->
+                         raise
+                          (PET.Fail
+                            (lazy ("The correctness of hypothesis " ^
+                             string_of_name n ^
+                             " relies on the body of " ^ hyp)
+                          )));
+                     entry::context
                ) canonical_context []
              in
               let _,_ =
@@ -93,13 +109,13 @@ let clearbody ~hyp =
          | t -> t
        ) metasenv
      in
-      (curi,metasenv',pbo,pty), [goal]
+      (curi,metasenv',_subst,pbo,pty, attrs), [goal]
  in
   PET.mk_tactic clearbody
 
 let clear_one ~hyp =
  let clear_one (proof, goal) =
-   let curi,metasenv,pbo,pty = proof in
+   let curi,metasenv,_subst,pbo,pty, attrs = proof in
     let metano,context,ty =
      CicUtil.lookup_meta goal metasenv
     in
@@ -151,7 +167,7 @@ let clear_one ~hyp =
          | t -> t
        ) metasenv
      in
-      (curi,metasenv',pbo,pty), [goal]
+      (curi,metasenv',_subst,pbo,pty, attrs), [goal]
  in
   PET.mk_tactic clear_one
 
@@ -176,7 +192,7 @@ let rename ~froms ~tos =
          try List.combine froms tos
         with Invalid_argument _ -> raise (PET.Fail (lazy error))
       in
-      let curi, metasenv, pbo, pty = proof in
+      let curi, metasenv, _subst, pbo, pty, attrs = proof in
       let metano, _, _ = CicUtil.lookup_meta goal metasenv in      
       let rename_map = function
          | Some (Cic.Name hyp, decl_or_def) as entry ->
@@ -191,15 +207,6 @@ let rename ~froms ~tos =
          | conjecture -> conjecture
       in
       let metasenv = List.map map metasenv in
-      (curi, metasenv, pbo, pty), [goal]
+      (curi, metasenv, _subst, pbo, pty, attrs), [goal]
    in
    PET.mk_tactic rename
-
-let set_goal n =
-  PET.mk_tactic
-    (fun (proof, goal) ->
-       let (_, metasenv, _, _) = proof in
-       if CicUtil.exists_meta n metasenv then
-         (proof, [n])
-       else
-         raise (PET.Fail (lazy ("no such meta: " ^ string_of_int n))))