better exception handling

[helm.git] / helm / software / components / ng_tactics / nTacStatus.ml

diff --git a/helm/software/components/ng_tactics/nTacStatus.ml b/helm/software/components/ng_tactics/nTacStatus.ml
index dc3816dab26a01c2c7ffaa197b8e5a8155706777..52a45bbd49dd83a2267997f0b9532cf9313753d2 100644 (file)
--- a/helm/software/components/ng_tactics/nTacStatus.ml
+++ b/helm/software/components/ng_tactics/nTacStatus.ml
@@ -11,8 +11,18 @@
 
 (* $Id: nCic.ml 9058 2008-10-13 17:42:30Z tassi $ *)
 
-exception Error of string lazy_t
-let fail msg = raise (Error msg)
+exception Error of string lazy_t * exn option
+let fail ?exn msg = raise (Error (msg,exn))
+
+let wrap f x = 
+  try f x 
+  with 
+  | MultiPassDisambiguator.DisambiguationError _ 
+  | NCicRefiner.RefineFailure _ 
+  | NCicUnification.UnificationFailure _ 
+  | NCicTypeChecker.TypeCheckerFailure _ 
+  | NCicMetaSubst.MetaSubstFailure _ as exn -> fail ~exn (lazy "")
+;;
 
 class pstatus =
  fun (o: NCic.obj) ->
@@ -26,12 +36,7 @@ class pstatus =
 type tactic_term = CicNotationPt.term Disambiguate.disambiguator_input
 type tactic_pattern = GrafiteAst.npattern Disambiguate.disambiguator_input
 
-let pp_tac_status status = 
-  prerr_endline (NCicPp.ppobj status#obj)
-;;
-
-let pp_lowtac_status status = 
-  prerr_endline "--------------------------------------------";
+let pp_status status = 
   prerr_endline (NCicPp.ppobj status#obj)
 ;;
 
@@ -87,6 +92,7 @@ let relocate status destination (name,source,t as orig) =
   let status = status#set_obj (u, d, metasenv, subst, o) in
   status, (name, destination, t)
 ;;
+let relocate a b c = wrap (relocate a b) c;;
 
 let term_of_cic_term s t c = 
   let s, (_,_,t) = relocate s c t in
@@ -113,6 +119,7 @@ let disambiguate status t ty context =
  let new_pstatus = uri,height,metasenv,subst,obj in
   status#set_obj new_pstatus, (None, context, t) 
 ;;
+let disambiguate a b c d = wrap (disambiguate a b c) d;;
 
 let typeof status ctx t =
   let status, (_,_,t) = relocate status ctx t in
@@ -120,6 +127,7 @@ let typeof status ctx t =
   let ty = NCicTypeChecker.typeof ~subst ~metasenv ctx t in
   status, (None, ctx, ty)
 ;;
+let typeof a b c = wrap (typeof a b) c;;
   
 let whd status ?delta ctx t =
   let status, (name,_,t) = relocate status ctx t in
@@ -142,6 +150,7 @@ let unify status ctx a b =
   let metasenv, subst = NCicUnification.unify status metasenv subst ctx a b in
    status#set_obj (n,h,metasenv,subst,o)
 ;;
+let unify a b c d = wrap (unify a b c) d;;
 
 let refine status ctx term expty =
   let status, (nt,_,term) = relocate status ctx term in
@@ -156,6 +165,7 @@ let refine status ctx term expty =
   in
    status#set_obj (name,height,metasenv,subst,obj), (nt,ctx,t), (ne,ctx,ty)
 ;;
+let refine a b c d = wrap (refine a b c) d;;
 
 let get_goalty status g =
  let _,_,metasenv,_,_ = status#obj in
@@ -330,6 +340,8 @@ let apply_subst status ctx t =
   status, (name, ctx, NCicUntrusted.apply_subst subst ctx t)
 ;;
 
+(* ============= move this elsewhere ====================*)
+
 class ['stack] status =
  fun (o: NCic.obj) (s: 'stack) ->
   object
@@ -346,3 +358,4 @@ type 'status lowtactic = #lowtac_status as 'status -> int -> 'status
 class type tac_status = [Continuationals.Stack.t] status
 
 type 'status tactic = #tac_status as 'status -> 'status
+