moved instantiate binding to extratactics

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@5852 85f007b7-540e-0410-9357-904b9bb8a0f7

1 files changed, 80 insertions, 0 deletions

diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 4aace33dcf..3fbd27c605 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -13,6 +13,9 @@
 open Pp
 open Pcoq
 open Genarg
+open Names
+open Tacexpr
+open Tacinterp
 
 (* Rewriting orientation *)
 
@@ -23,9 +26,86 @@ let pr_orient _prc _prt = function
   | true -> Pp.mt ()
   | false -> Pp.str " <-"
 
+
 ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
 | [ "->" ] -> [ true ]
 | [ "<-" ] -> [ false ]
 | [ ] -> [ true ]
 END
 
+
+let pr_gen prc _ c = prc c
+
+let pr_rawc _ _ raw = Ppconstr.pr_rawconstr raw
+
+let interp_raw _ _ (t,_) = t
+
+let glob_raw ist a = Tacinterp.intern_constr ist a
+
+let subst_raw subst arawc = Tacinterp.subst_rawconstr subst arawc
+
+ARGUMENT EXTEND raw
+    TYPED AS rawconstr
+    PRINTED BY pr_rawc
+     
+     INTERPRETED BY interp_raw	
+     GLOBALIZED BY glob_raw
+     SUBSTITUTED BY subst_raw
+     
+     RAW_TYPED AS constr_expr
+     RAW_PRINTED BY pr_gen
+     
+     GLOB_TYPED AS rawconstr_and_expr
+     GLOB_PRINTED BY pr_gen
+
+ [ constr(c) ] -> [ c ]
+
+END
+
+type 'id gen_place= ('id * hyp_location_flag,unit) location
+
+type loc_place = identifier Util.located gen_place
+type place = identifier gen_place
+
+let pr_gen_place pr_id = function
+    ConclLocation () -> Pp.mt ()
+  | HypLocation (id,InHyp) -> str "in " ++ pr_id id
+  | HypLocation (id,InHypTypeOnly) -> 
+      str "in (Type of " ++ pr_id id ++ str ")"
+  | HypLocation (id,InHypValueOnly) -> 
+      str "in (Value of " ++ pr_id id ++ str ")"
+
+let pr_loc_place _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id)
+let pr_place _ _ = pr_gen_place Nameops.pr_id
+
+let intern_place ist = function
+    ConclLocation () -> ConclLocation ()
+  | HypLocation (id,hl) -> HypLocation (intern_hyp ist id,hl)
+
+let interp_place ist gl = function
+    ConclLocation () -> ConclLocation ()
+  | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
+
+let subst_place subst pl = pl 
+
+ARGUMENT EXTEND hloc
+    TYPED AS place
+    PRINTED BY pr_place
+    INTERPRETED BY interp_place
+    GLOBALIZED BY intern_place
+    SUBSTITUTED BY subst_place
+    RAW_TYPED AS loc_place
+    RAW_PRINTED BY pr_loc_place
+    GLOB_TYPED AS loc_place
+    GLOB_PRINTED BY pr_loc_place
+  [ ] -> 
+    [ ConclLocation () ]
+| [ "in" ident(id) ] ->
+    [ HypLocation ((Util.dummy_loc,id),InHyp) ]
+| [ "in" "(" "Type" "of" ident(id) ")" ] -> 
+    [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ]
+| [ "in" "(" "Value" "of" ident(id) ")" ] -> 
+    [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ]
+   
+ END
+