PageRenderTime 55ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 1ms

/parsing/pptactic.ml

http://github.com/mzp/coq-ruby
OCaml | 1098 lines | 901 code | 135 blank | 62 comment | 43 complexity | cfc7c3739ca8d2ef0fc9e0da9f61f1f1 MD5 | raw file
Possible License(s): LGPL-2.1, LGPL-2.0
  1. (************************************************************************)
  2. (* v * The Coq Proof Assistant / The Coq Development Team *)
  3. (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
  4. (* \VV/ **************************************************************)
  5. (* // * This file is distributed under the terms of the *)
  6. (* * GNU Lesser General Public License Version 2.1 *)
  7. (************************************************************************)
  8. (* $Id: pptactic.ml 12581 2009-12-13 15:02:33Z herbelin $ *)
  9. open Pp
  10. open Names
  11. open Nameops
  12. open Util
  13. open Tacexpr
  14. open Rawterm
  15. open Topconstr
  16. open Genarg
  17. open Libnames
  18. open Pattern
  19. open Ppextend
  20. open Ppconstr
  21. open Printer
  22. open Termops
  23. let pr_global x = Nametab.pr_global_env Idset.empty x
  24. type grammar_terminals = string option list
  25. (* Extensions *)
  26. let prtac_tab = Hashtbl.create 17
  27. let declare_extra_tactic_pprule (s,tags,prods) =
  28. Hashtbl.add prtac_tab (s,tags) prods
  29. let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags)
  30. type 'a raw_extra_genarg_printer =
  31. (constr_expr -> std_ppcmds) ->
  32. (constr_expr -> std_ppcmds) ->
  33. (tolerability -> raw_tactic_expr -> std_ppcmds) ->
  34. 'a -> std_ppcmds
  35. type 'a glob_extra_genarg_printer =
  36. (rawconstr_and_expr -> std_ppcmds) ->
  37. (rawconstr_and_expr -> std_ppcmds) ->
  38. (tolerability -> glob_tactic_expr -> std_ppcmds) ->
  39. 'a -> std_ppcmds
  40. type 'a extra_genarg_printer =
  41. (Term.constr -> std_ppcmds) ->
  42. (Term.constr -> std_ppcmds) ->
  43. (tolerability -> glob_tactic_expr -> std_ppcmds) ->
  44. 'a -> std_ppcmds
  45. let genarg_pprule = ref Stringmap.empty
  46. let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) =
  47. let s = match unquote wit with
  48. | ExtraArgType s -> s
  49. | _ -> error
  50. "Can declare a pretty-printing rule only for extra argument types."
  51. in
  52. let f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in
  53. let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in
  54. let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in
  55. genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule
  56. let pr_arg pr x = spc () ++ pr x
  57. let pr_or_var pr = function
  58. | ArgArg x -> pr x
  59. | ArgVar (_,s) -> pr_id s
  60. let pr_or_metaid pr = function
  61. | AI x -> pr x
  62. | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable"
  63. let pr_and_short_name pr (c,_) = pr c
  64. let pr_or_by_notation f = function
  65. | AN v -> f v
  66. | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
  67. let pr_located pr (loc,x) = pr x
  68. let pr_evaluable_reference = function
  69. | EvalVarRef id -> pr_id id
  70. | EvalConstRef sp -> pr_global (Libnames.ConstRef sp)
  71. let pr_quantified_hypothesis = function
  72. | AnonHyp n -> int n
  73. | NamedHyp id -> pr_id id
  74. let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
  75. let pr_binding prc = function
  76. | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
  77. | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
  78. let pr_bindings prc prlc = function
  79. | ImplicitBindings l ->
  80. brk (1,1) ++ str "with" ++ brk (1,1) ++
  81. prlist_with_sep spc prc l
  82. | ExplicitBindings l ->
  83. brk (1,1) ++ str "with" ++ brk (1,1) ++
  84. prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
  85. | NoBindings -> mt ()
  86. let pr_bindings_no_with prc prlc = function
  87. | ImplicitBindings l ->
  88. brk (1,1) ++
  89. prlist_with_sep spc prc l
  90. | ExplicitBindings l ->
  91. brk (1,1) ++
  92. prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
  93. | NoBindings -> mt ()
  94. let pr_with_bindings prc prlc (c,bl) =
  95. prc c ++ hv 0 (pr_bindings prc prlc bl)
  96. let pr_with_constr prc = function
  97. | None -> mt ()
  98. | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
  99. let rec pr_message_token prid = function
  100. | MsgString s -> qs s
  101. | MsgInt n -> int n
  102. | MsgIdent id -> prid id
  103. let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s)
  104. let with_evars ev s = if ev then "e" ^ s else s
  105. let out_bindings = function
  106. | ImplicitBindings l -> ImplicitBindings (List.map snd l)
  107. | ExplicitBindings l -> ExplicitBindings (List.map (fun (loc,id,c) -> (loc,id,snd c)) l)
  108. | NoBindings -> NoBindings
  109. let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c
  110. let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argument) =
  111. match Genarg.genarg_tag x with
  112. | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false")
  113. | IntArgType -> int (out_gen rawwit_int x)
  114. | IntOrVarArgType -> pr_or_var pr_int (out_gen rawwit_int_or_var x)
  115. | StringArgType -> str "\"" ++ str (out_gen rawwit_string x) ++ str "\""
  116. | PreIdentArgType -> str (out_gen rawwit_pre_ident x)
  117. | IntroPatternArgType -> pr_intro_pattern (out_gen rawwit_intro_pattern x)
  118. | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x)
  119. | VarArgType -> pr_located pr_id (out_gen rawwit_var x)
  120. | RefArgType -> prref (out_gen rawwit_ref x)
  121. | SortArgType -> pr_rawsort (out_gen rawwit_sort x)
  122. | ConstrArgType -> prc (out_gen rawwit_constr x)
  123. | ConstrMayEvalArgType ->
  124. pr_may_eval prc prlc (pr_or_by_notation prref)
  125. (out_gen rawwit_constr_may_eval x)
  126. | QuantHypArgType -> pr_quantified_hypothesis (out_gen rawwit_quant_hyp x)
  127. | RedExprArgType ->
  128. pr_red_expr (prc,prlc,pr_or_by_notation prref)
  129. (out_gen rawwit_red_expr x)
  130. | OpenConstrArgType b -> prc (snd (out_gen (rawwit_open_constr_gen b) x))
  131. | ConstrWithBindingsArgType ->
  132. pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x)
  133. | BindingsArgType ->
  134. pr_bindings_no_with prc prlc (out_gen rawwit_bindings x)
  135. | List0ArgType _ ->
  136. hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref)
  137. (fold_list0 (fun a l -> a::l) x []))
  138. | List1ArgType _ ->
  139. hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref)
  140. (fold_list1 (fun a l -> a::l) x []))
  141. | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prref) (mt()) x)
  142. | PairArgType _ ->
  143. hov 0
  144. (fold_pair
  145. (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prref) [a;b])
  146. x)
  147. | ExtraArgType s ->
  148. try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x
  149. with Not_found -> str "[no printer for " ++ str s ++ str "]"
  150. let rec pr_glob_generic prc prlc prtac x =
  151. match Genarg.genarg_tag x with
  152. | BoolArgType -> str (if out_gen globwit_bool x then "true" else "false")
  153. | IntArgType -> int (out_gen globwit_int x)
  154. | IntOrVarArgType -> pr_or_var pr_int (out_gen globwit_int_or_var x)
  155. | StringArgType -> str "\"" ++ str (out_gen globwit_string x) ++ str "\""
  156. | PreIdentArgType -> str (out_gen globwit_pre_ident x)
  157. | IntroPatternArgType -> pr_intro_pattern (out_gen globwit_intro_pattern x)
  158. | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x)
  159. | VarArgType -> pr_located pr_id (out_gen globwit_var x)
  160. | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x)
  161. | SortArgType -> pr_rawsort (out_gen globwit_sort x)
  162. | ConstrArgType -> prc (out_gen globwit_constr x)
  163. | ConstrMayEvalArgType ->
  164. pr_may_eval prc prlc
  165. (pr_or_var (pr_and_short_name pr_evaluable_reference))
  166. (out_gen globwit_constr_may_eval x)
  167. | QuantHypArgType ->
  168. pr_quantified_hypothesis (out_gen globwit_quant_hyp x)
  169. | RedExprArgType ->
  170. pr_red_expr
  171. (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference))
  172. (out_gen globwit_red_expr x)
  173. | OpenConstrArgType b -> prc (snd (out_gen (globwit_open_constr_gen b) x))
  174. | ConstrWithBindingsArgType ->
  175. pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x)
  176. | BindingsArgType ->
  177. pr_bindings_no_with prc prlc (out_gen globwit_bindings x)
  178. | List0ArgType _ ->
  179. hov 0 (pr_sequence (pr_glob_generic prc prlc prtac)
  180. (fold_list0 (fun a l -> a::l) x []))
  181. | List1ArgType _ ->
  182. hov 0 (pr_sequence (pr_glob_generic prc prlc prtac)
  183. (fold_list1 (fun a l -> a::l) x []))
  184. | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac) (mt()) x)
  185. | PairArgType _ ->
  186. hov 0
  187. (fold_pair
  188. (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac) [a;b])
  189. x)
  190. | ExtraArgType s ->
  191. try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x
  192. with Not_found -> str "[no printer for " ++ str s ++ str "]"
  193. open Closure
  194. let rec pr_generic prc prlc prtac x =
  195. match Genarg.genarg_tag x with
  196. | BoolArgType -> str (if out_gen wit_bool x then "true" else "false")
  197. | IntArgType -> int (out_gen wit_int x)
  198. | IntOrVarArgType -> pr_or_var pr_int (out_gen wit_int_or_var x)
  199. | StringArgType -> str "\"" ++ str (out_gen wit_string x) ++ str "\""
  200. | PreIdentArgType -> str (out_gen wit_pre_ident x)
  201. | IntroPatternArgType -> pr_intro_pattern (out_gen wit_intro_pattern x)
  202. | IdentArgType b -> if_pattern_ident b pr_id (out_gen wit_ident x)
  203. | VarArgType -> pr_id (out_gen wit_var x)
  204. | RefArgType -> pr_global (out_gen wit_ref x)
  205. | SortArgType -> pr_sort (out_gen wit_sort x)
  206. | ConstrArgType -> prc (out_gen wit_constr x)
  207. | ConstrMayEvalArgType -> prc (out_gen wit_constr_may_eval x)
  208. | QuantHypArgType -> pr_quantified_hypothesis (out_gen wit_quant_hyp x)
  209. | RedExprArgType ->
  210. pr_red_expr (prc,prlc,pr_evaluable_reference) (out_gen wit_red_expr x)
  211. | OpenConstrArgType b -> prc (snd (out_gen (wit_open_constr_gen b) x))
  212. | ConstrWithBindingsArgType ->
  213. let (c,b) = out_gen wit_constr_with_bindings x in
  214. pr_with_bindings prc prlc (c,out_bindings b)
  215. | BindingsArgType ->
  216. pr_bindings_no_with prc prlc (out_bindings (out_gen wit_bindings x))
  217. | List0ArgType _ ->
  218. hov 0 (pr_sequence (pr_generic prc prlc prtac)
  219. (fold_list0 (fun a l -> a::l) x []))
  220. | List1ArgType _ ->
  221. hov 0 (pr_sequence (pr_generic prc prlc prtac)
  222. (fold_list1 (fun a l -> a::l) x []))
  223. | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac) (mt()) x)
  224. | PairArgType _ ->
  225. hov 0
  226. (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac) [a;b])
  227. x)
  228. | ExtraArgType s ->
  229. try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x
  230. with Not_found -> str "[no printer for " ++ str s ++ str "]"
  231. let rec tacarg_using_rule_token pr_gen = function
  232. | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al)
  233. | None :: l, a :: al -> pr_gen a :: tacarg_using_rule_token pr_gen (l,al)
  234. | [], [] -> []
  235. | _ -> failwith "Inconsistent arguments of extended tactic"
  236. let pr_tacarg_using_rule pr_gen l=
  237. pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l)
  238. let pr_extend_gen pr_gen lev s l =
  239. try
  240. let tags = List.map genarg_tag l in
  241. let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
  242. let p = pr_tacarg_using_rule pr_gen (pl,l) in
  243. if lev' > lev then surround p else p
  244. with Not_found ->
  245. str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)"
  246. let pr_raw_extend prc prlc prtac =
  247. pr_extend_gen (pr_raw_generic prc prlc prtac pr_reference)
  248. let pr_glob_extend prc prlc prtac =
  249. pr_extend_gen (pr_glob_generic prc prlc prtac)
  250. let pr_extend prc prlc prtac =
  251. pr_extend_gen (pr_generic (fun c -> prc (Evd.empty,c)) (fun c -> prlc (Evd.empty,c)) prtac)
  252. (**********************************************************************)
  253. (* The tactic printer *)
  254. let sep_v = fun _ -> str"," ++ spc()
  255. let strip_prod_binders_expr n ty =
  256. let rec strip_ty acc n ty =
  257. match ty with
  258. Topconstr.CProdN(_,bll,a) ->
  259. let nb =
  260. List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in
  261. let bll = List.map (fun (x, _, y) -> x, y) bll in
  262. if nb >= n then (List.rev (bll@acc)), a
  263. else strip_ty (bll@acc) (n-nb) a
  264. | Topconstr.CArrow(_,a,b) ->
  265. if n=1 then
  266. (List.rev (([(dummy_loc,Anonymous)],a)::acc), b)
  267. else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b
  268. | _ -> error "Cannot translate fix tactic: not enough products" in
  269. strip_ty [] n ty
  270. let pr_ltac_or_var pr = function
  271. | ArgArg x -> pr x
  272. | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
  273. let pr_arg pr x = spc () ++ pr x
  274. let pr_ltac_constant sp =
  275. pr_qualid (Nametab.shortest_qualid_of_tactic sp)
  276. let pr_evaluable_reference_env env = function
  277. | EvalVarRef id -> pr_id id
  278. | EvalConstRef sp ->
  279. Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp)
  280. let pr_quantified_hypothesis = function
  281. | AnonHyp n -> int n
  282. | NamedHyp id -> pr_id id
  283. let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
  284. let pr_esubst prc l =
  285. let pr_qhyp = function
  286. (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
  287. | (_,NamedHyp id,c) ->
  288. str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
  289. in
  290. prlist_with_sep spc pr_qhyp l
  291. let pr_bindings_gen for_ex prlc prc = function
  292. | ImplicitBindings l ->
  293. spc () ++
  294. hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
  295. prlist_with_sep spc prc l)
  296. | ExplicitBindings l ->
  297. spc () ++
  298. hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
  299. pr_esubst prlc l)
  300. | NoBindings -> mt ()
  301. let pr_bindings prlc prc = pr_bindings_gen false prlc prc
  302. let pr_with_bindings prlc prc (c,bl) =
  303. hov 1 (prc c ++ pr_bindings prlc prc bl)
  304. let pr_with_constr prc = function
  305. | None -> mt ()
  306. | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
  307. let pr_with_induction_names = function
  308. | None, None -> mt ()
  309. | eqpat, ipat ->
  310. spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++
  311. pr_opt pr_intro_pattern ipat)
  312. let pr_as_intro_pattern ipat =
  313. spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
  314. let pr_with_inversion_names = function
  315. | None -> mt ()
  316. | Some ipat -> pr_as_intro_pattern ipat
  317. let pr_as_ipat = function
  318. | None -> mt ()
  319. | Some ipat -> pr_as_intro_pattern ipat
  320. let pr_as_name = function
  321. | Anonymous -> mt ()
  322. | Name id -> str " as " ++ pr_lident (dummy_loc,id)
  323. let pr_pose_as_style prc na c =
  324. spc() ++ prc c ++ pr_as_name na
  325. let pr_pose prlc prc na c = match na with
  326. | Anonymous -> spc() ++ prc c
  327. | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
  328. let pr_assertion _prlc prc ipat c = match ipat with
  329. (* Use this "optimisation" or use only the general case ?
  330. | IntroIdentifier id ->
  331. spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
  332. *)
  333. | ipat ->
  334. spc() ++ prc c ++ pr_as_ipat ipat
  335. let pr_assumption prlc prc ipat c = match ipat with
  336. (* Use this "optimisation" or use only the general case ?
  337. | IntroIdentifier id ->
  338. spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
  339. *)
  340. | ipat ->
  341. spc() ++ prc c ++ pr_as_ipat ipat
  342. let pr_by_tactic prt = function
  343. | TacId [] -> mt ()
  344. | tac -> spc() ++ str "by " ++ prt tac
  345. let pr_hyp_location pr_id = function
  346. | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
  347. | occs, InHypTypeOnly ->
  348. spc () ++
  349. pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs
  350. | occs, InHypValueOnly ->
  351. spc () ++
  352. pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs
  353. let pr_in pp = spc () ++ hov 0 (str "in" ++ pp)
  354. let pr_simple_clause pr_id = function
  355. | [] -> mt ()
  356. | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
  357. let pr_in_hyp_as pr_id = function
  358. | None -> mt ()
  359. | Some (id,ipat) -> pr_simple_clause pr_id [id] ++ pr_as_ipat ipat
  360. let pr_clauses pr_id = function
  361. | { onhyps=None; concl_occs=occs } ->
  362. if occs = no_occurrences_expr then pr_in (str " * |-")
  363. else pr_in (pr_with_occurrences (fun () -> str " *") (occs,()))
  364. | { onhyps=Some l; concl_occs=occs } ->
  365. pr_in
  366. (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++
  367. (if occs = no_occurrences_expr then mt ()
  368. else pr_with_occurrences (fun () -> str" |- *") (occs,())))
  369. let pr_clause_pattern pr_id = function
  370. | (None, []) -> mt ()
  371. | (glopt,l) ->
  372. str " in" ++
  373. prlist
  374. (fun (id,nl) -> prlist (pr_arg int) nl
  375. ++ spc () ++ pr_id id) l ++
  376. pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt
  377. let pr_orient b = if b then mt () else str " <-"
  378. let pr_multi = function
  379. | Precisely 1 -> mt ()
  380. | Precisely n -> pr_int n ++ str "!"
  381. | UpTo n -> pr_int n ++ str "?"
  382. | RepeatStar -> str "?"
  383. | RepeatPlus -> str "!"
  384. let pr_induction_arg prlc prc = function
  385. | ElimOnConstr c -> pr_with_bindings prlc prc c
  386. | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
  387. | ElimOnAnonHyp n -> int n
  388. let pr_induction_kind = function
  389. | SimpleInversion -> str "simple inversion"
  390. | FullInversion -> str "inversion"
  391. | FullInversionClear -> str "inversion_clear"
  392. let pr_lazy lz = if lz then str "lazy" else mt ()
  393. let pr_match_pattern pr_pat = function
  394. | Term a -> pr_pat a
  395. | Subterm (b,None,a) -> (if b then str"appcontext [" else str "context [") ++ pr_pat a ++ str "]"
  396. | Subterm (b,Some id,a) ->
  397. (if b then str"appcontext " else str "context ") ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
  398. let pr_match_hyps pr_pat = function
  399. | Hyp (nal,mp) ->
  400. pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
  401. | Def (nal,mv,mp) ->
  402. pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv
  403. ++ str ":" ++ pr_match_pattern pr_pat mp
  404. let pr_match_rule m pr pr_pat = function
  405. | Pat ([],mp,t) when m ->
  406. pr_match_pattern pr_pat mp ++
  407. spc () ++ str "=>" ++ brk (1,4) ++ pr t
  408. (*
  409. | Pat (rl,mp,t) ->
  410. hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl ++
  411. (if rl <> [] then spc () else mt ()) ++
  412. hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
  413. str "=>" ++ brk (1,4) ++ pr t))
  414. *)
  415. | Pat (rl,mp,t) ->
  416. hov 0 (
  417. hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl) ++
  418. (if rl <> [] then spc () else mt ()) ++
  419. hov 0 (
  420. str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
  421. str "=>" ++ brk (1,4) ++ pr t))
  422. | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
  423. let pr_funvar = function
  424. | None -> spc () ++ str "_"
  425. | Some id -> spc () ++ pr_id id
  426. let pr_let_clause k pr (id,(bl,t)) =
  427. hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++
  428. str " :=" ++ brk (1,1) ++ pr (TacArg t))
  429. let pr_let_clauses recflag pr = function
  430. | hd::tl ->
  431. hv 0
  432. (pr_let_clause (if recflag then "let rec " else "let ") pr hd ++
  433. prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl)
  434. | [] -> anomaly "LetIn must declare at least one binding"
  435. let pr_seq_body pr tl =
  436. hv 0 (str "[ " ++
  437. prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
  438. str " ]")
  439. let pr_opt_tactic pr = function
  440. | TacId [] -> mt ()
  441. | t -> pr t
  442. let pr_then_gen pr tf tm tl =
  443. hv 0 (str "[ " ++
  444. prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++
  445. pr_opt_tactic pr tm ++ str ".." ++
  446. prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl ++
  447. str " ]")
  448. let pr_hintbases = function
  449. | None -> spc () ++ str "with *"
  450. | Some [] -> mt ()
  451. | Some l ->
  452. spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l)
  453. let pr_auto_using prc = function
  454. | [] -> mt ()
  455. | l -> spc () ++
  456. hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_coma prc l)
  457. let pr_autoarg_adding = function
  458. | [] -> mt ()
  459. | l ->
  460. spc () ++ str "adding [" ++
  461. hv 0 (prlist_with_sep spc pr_reference l) ++ str "]"
  462. let pr_autoarg_destructing = function
  463. | true -> spc () ++ str "destructing"
  464. | false -> mt ()
  465. let pr_autoarg_usingTDB = function
  466. | true -> spc () ++ str "using tdb"
  467. | false -> mt ()
  468. let rec pr_tacarg_using_rule pr_gen = function
  469. | Egrammar.TacTerm s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
  470. | Egrammar.TacNonTerm _ :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al)
  471. | [], [] -> mt ()
  472. | _ -> failwith "Inconsistent arguments of extended tactic"
  473. let pr_then () = str ";"
  474. let ltop = (5,E)
  475. let lseq = 4
  476. let ltactical = 3
  477. let lorelse = 2
  478. let llet = 5
  479. let lfun = 5
  480. let lcomplete = 1
  481. let labstract = 3
  482. let lmatch = 1
  483. let latom = 0
  484. let lcall = 1
  485. let leval = 1
  486. let ltatom = 1
  487. let linfo = 5
  488. let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
  489. open Closure
  490. (** A printer for tactics that polymorphically works on the three
  491. "raw", "glob" and "typed" levels; in practice, the environment is
  492. used only at the glob and typed level: it is used to feed the
  493. constr printers *)
  494. let make_pr_tac
  495. (pr_tac_level,pr_constr,pr_lconstr,pr_pat,
  496. pr_cst,pr_ind,pr_ref,pr_ident,
  497. pr_extend,strip_prod_binders) env =
  498. (* The environment is not used by the tactic printer: it is passed to the
  499. constr and cst printers; hence we can make some abbreviations *)
  500. let pr_constr = pr_constr env in
  501. let pr_lconstr = pr_lconstr env in
  502. let pr_cst = pr_cst env in
  503. let pr_ind = pr_ind env in
  504. let pr_tac_level = pr_tac_level env in
  505. (* Other short cuts *)
  506. let pr_bindings = pr_bindings pr_lconstr pr_constr in
  507. let pr_ex_bindings = pr_bindings_gen true pr_lconstr pr_constr in
  508. let pr_with_bindings = pr_with_bindings pr_lconstr pr_constr in
  509. let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level in
  510. let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst) in
  511. let pr_constrarg c = spc () ++ pr_constr c in
  512. let pr_lconstrarg c = spc () ++ pr_lconstr c in
  513. let pr_intarg n = spc () ++ int n in
  514. (* Some printing combinators *)
  515. let pr_eliminator cb = str "using" ++ pr_arg pr_with_bindings cb in
  516. let extract_binders = function
  517. | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body)
  518. | body -> ([],body) in
  519. let pr_binder_fix (nal,t) =
  520. (* match t with
  521. | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
  522. | _ ->*)
  523. let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr_lconstr t in
  524. spc() ++ hov 1 (str"(" ++ s ++ str")") in
  525. let pr_fix_tac (id,n,c) =
  526. let rec set_nth_name avoid n = function
  527. (nal,ty)::bll ->
  528. if n <= List.length nal then
  529. match list_chop (n-1) nal with
  530. _, (_,Name id) :: _ -> id, (nal,ty)::bll
  531. | bef, (loc,Anonymous) :: aft ->
  532. let id = next_ident_away_from (id_of_string"y") avoid in
  533. id, ((bef@(loc,Name id)::aft, ty)::bll)
  534. | _ -> assert false
  535. else
  536. let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
  537. (id,(nal,ty)::bll')
  538. | [] -> assert false in
  539. let (bll,ty) = strip_prod_binders n c in
  540. let names =
  541. List.fold_left
  542. (fun ln (nal,_) -> List.fold_left
  543. (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
  544. ln nal)
  545. [] bll in
  546. let idarg,bll = set_nth_name names n bll in
  547. let annot =
  548. if List.length names = 1 then mt()
  549. else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in
  550. hov 1 (str"(" ++ pr_id id ++
  551. prlist pr_binder_fix bll ++ annot ++ str" :" ++
  552. pr_lconstrarg ty ++ str")") in
  553. (* spc() ++
  554. hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
  555. c)
  556. *)
  557. let pr_cofix_tac (id,c) =
  558. hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
  559. (* Printing tactics as arguments *)
  560. let rec pr_atom0 = function
  561. | TacIntroPattern [] -> str "intros"
  562. | TacIntroMove (None,hto) when hto = no_move -> str "intro"
  563. | TacAssumption -> str "assumption"
  564. | TacAnyConstructor (false,None) -> str "constructor"
  565. | TacAnyConstructor (true,None) -> str "econstructor"
  566. | TacTrivial ([],Some []) -> str "trivial"
  567. | TacAuto (None,[],Some []) -> str "auto"
  568. | TacReflexivity -> str "reflexivity"
  569. | TacClear (true,[]) -> str "clear"
  570. | t -> str "(" ++ pr_atom1 t ++ str ")"
  571. (* Main tactic printer *)
  572. and pr_atom1 = function
  573. | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl
  574. | TacSuperAuto _ | TacExtend (_,
  575. ("GTauto"|"GIntuition"|"TSimplif"|
  576. "LinearIntuition"),_) ->
  577. errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0")
  578. | TacExtend (loc,s,l) ->
  579. pr_with_comments loc (pr_extend 1 s l)
  580. | TacAlias (loc,s,l,_) ->
  581. pr_with_comments loc (pr_extend 1 s (List.map snd l))
  582. (* Basic tactics *)
  583. | TacIntroPattern [] as t -> pr_atom0 t
  584. | TacIntroPattern (_::_ as p) ->
  585. hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
  586. | TacIntrosUntil h ->
  587. hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h)
  588. | TacIntroMove (None,hto) as t when hto = no_move -> pr_atom0 t
  589. | TacIntroMove (Some id,hto) when hto = no_move -> str "intro " ++ pr_id id
  590. | TacIntroMove (ido,hto) ->
  591. hov 1 (str"intro" ++ pr_opt pr_id ido ++ pr_move_location pr_ident hto)
  592. | TacAssumption as t -> pr_atom0 t
  593. | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c)
  594. | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c)
  595. | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c)
  596. | TacApply (a,ev,cb,inhyp) ->
  597. hov 1 ((if a then mt() else str "simple ") ++
  598. str (with_evars ev "apply") ++ spc () ++
  599. prlist_with_sep pr_coma pr_with_bindings cb ++
  600. pr_in_hyp_as pr_ident inhyp)
  601. | TacElim (ev,cb,cbo) ->
  602. hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++
  603. pr_opt pr_eliminator cbo)
  604. | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c)
  605. | TacCase (ev,cb) ->
  606. hov 1 (str (with_evars ev "case") ++ spc () ++ pr_with_bindings cb)
  607. | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg c)
  608. | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n)
  609. | TacMutualFix (hidden,id,n,l) ->
  610. if hidden then str "idtac" (* should caught before! *) else
  611. hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++
  612. str"with " ++ prlist_with_sep spc pr_fix_tac l)
  613. | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido)
  614. | TacMutualCofix (hidden,id,l) ->
  615. if hidden then str "idtac" (* should be caught before! *) else
  616. hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++
  617. str"with " ++ prlist_with_sep spc pr_cofix_tac l)
  618. | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c)
  619. | TacAssert (Some tac,ipat,c) ->
  620. hov 1 (str "assert" ++
  621. pr_assumption pr_lconstr pr_constr ipat c ++
  622. pr_by_tactic (pr_tac_level ltop) tac)
  623. | TacAssert (None,ipat,c) ->
  624. hov 1 (str "pose proof" ++
  625. pr_assertion pr_lconstr pr_constr ipat c)
  626. | TacGeneralize l ->
  627. hov 1 (str "generalize" ++ spc () ++
  628. prlist_with_sep pr_coma (fun (cl,na) ->
  629. pr_with_occurrences pr_constr cl ++ pr_as_name na)
  630. l)
  631. | TacGeneralizeDep c ->
  632. hov 1 (str "generalize" ++ spc () ++ str "dependent" ++
  633. pr_constrarg c)
  634. | TacLetTac (na,c,cl,true) when cl = nowhere ->
  635. hov 1 (str "pose" ++ pr_pose pr_lconstr pr_constr na c)
  636. | TacLetTac (na,c,cl,b) ->
  637. hov 1 ((if b then str "set" else str "remember") ++
  638. (if b then pr_pose pr_lconstr else pr_pose_as_style)
  639. pr_constr na c ++
  640. pr_clauses pr_ident cl)
  641. (* | TacInstantiate (n,c,ConclLocation ()) ->
  642. hov 1 (str "instantiate" ++ spc() ++
  643. hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
  644. pr_lconstrarg c ++ str ")" ))
  645. | TacInstantiate (n,c,HypLocation (id,hloc)) ->
  646. hov 1 (str "instantiate" ++ spc() ++
  647. hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
  648. pr_lconstrarg c ++ str ")" )
  649. ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None)))
  650. *)
  651. (* Derived basic tactics *)
  652. | TacSimpleInductionDestruct (isrec,h) ->
  653. hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct")
  654. ++ pr_arg pr_quantified_hypothesis h)
  655. | TacInductionDestruct (isrec,ev,l) ->
  656. hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++
  657. spc () ++
  658. prlist_with_sep pr_coma (fun (h,e,ids,cl) ->
  659. prlist_with_sep spc (pr_induction_arg pr_lconstr pr_constr) h ++
  660. pr_with_induction_names ids ++
  661. pr_opt pr_eliminator e ++
  662. pr_opt_no_spc (pr_clauses pr_ident) cl) l)
  663. | TacDoubleInduction (h1,h2) ->
  664. hov 1
  665. (str "double induction" ++
  666. pr_arg pr_quantified_hypothesis h1 ++
  667. pr_arg pr_quantified_hypothesis h2)
  668. | TacDecomposeAnd c ->
  669. hov 1 (str "decompose record" ++ pr_constrarg c)
  670. | TacDecomposeOr c ->
  671. hov 1 (str "decompose sum" ++ pr_constrarg c)
  672. | TacDecompose (l,c) ->
  673. hov 1 (str "decompose" ++ spc () ++
  674. hov 0 (str "[" ++ prlist_with_sep spc pr_ind l
  675. ++ str "]" ++ pr_constrarg c))
  676. | TacSpecialize (n,c) ->
  677. hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++
  678. pr_with_bindings c)
  679. | TacLApply c ->
  680. hov 1 (str "lapply" ++ pr_constrarg c)
  681. (* Automation tactics *)
  682. | TacTrivial ([],Some []) as x -> pr_atom0 x
  683. | TacTrivial (lems,db) ->
  684. hov 0 (str "trivial" ++
  685. pr_auto_using pr_constr lems ++ pr_hintbases db)
  686. | TacAuto (None,[],Some []) as x -> pr_atom0 x
  687. | TacAuto (n,lems,db) ->
  688. hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++
  689. pr_auto_using pr_constr lems ++ pr_hintbases db)
  690. | TacDAuto (n,p,lems) ->
  691. hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++
  692. pr_opt int p ++ pr_auto_using pr_constr lems)
  693. (* Context management *)
  694. | TacClear (true,[]) as t -> pr_atom0 t
  695. | TacClear (keep,l) ->
  696. hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++
  697. prlist_with_sep spc pr_ident l)
  698. | TacClearBody l ->
  699. hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l)
  700. | TacMove (b,id1,id2) ->
  701. (* Rem: only b = true is available for users *)
  702. assert b;
  703. hov 1
  704. (str "move" ++ brk (1,1) ++ pr_ident id1 ++
  705. pr_move_location pr_ident id2)
  706. | TacRename l ->
  707. hov 1
  708. (str "rename" ++ brk (1,1) ++
  709. prlist_with_sep
  710. (fun () -> str "," ++ brk (1,1))
  711. (fun (i1,i2) ->
  712. pr_ident i1 ++ spc () ++ str "into" ++ spc () ++ pr_ident i2)
  713. l)
  714. | TacRevert l ->
  715. hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l)
  716. (* Constructors *)
  717. | TacLeft (ev,l) -> hov 1 (str (with_evars ev "left") ++ pr_bindings l)
  718. | TacRight (ev,l) -> hov 1 (str (with_evars ev "right") ++ pr_bindings l)
  719. | TacSplit (ev,false,l) -> hov 1 (str (with_evars ev "split") ++ pr_bindings l)
  720. | TacSplit (ev,true,l) -> hov 1 (str (with_evars ev "exists") ++ pr_ex_bindings l)
  721. | TacAnyConstructor (ev,Some t) ->
  722. hov 1 (str (with_evars ev "constructor") ++ pr_arg (pr_tac_level (latom,E)) t)
  723. | TacAnyConstructor (ev,None) as t -> pr_atom0 t
  724. | TacConstructor (ev,n,l) ->
  725. hov 1 (str (with_evars ev "constructor") ++
  726. pr_or_metaid pr_intarg n ++ pr_bindings l)
  727. (* Conversion *)
  728. | TacReduce (r,h) ->
  729. hov 1 (pr_red_expr r ++
  730. pr_clauses pr_ident h)
  731. | TacChange (occ,c,h) ->
  732. hov 1 (str "change" ++ brk (1,1) ++
  733. (match occ with
  734. None -> mt()
  735. | Some occlc ->
  736. pr_with_occurrences_with_trailer pr_constr occlc
  737. (spc () ++ str "with ")) ++
  738. pr_constr c ++ pr_clauses pr_ident h)
  739. (* Equivalence relations *)
  740. | TacReflexivity as x -> pr_atom0 x
  741. | TacSymmetry cls -> str "symmetry " ++ pr_clauses pr_ident cls
  742. | TacTransitivity c -> str "transitivity" ++ pr_constrarg c
  743. (* Equality and inversion *)
  744. | TacRewrite (ev,l,cl,by) ->
  745. hov 1 (str (with_evars ev "rewrite") ++
  746. prlist_with_sep
  747. (fun () -> str ","++spc())
  748. (fun (b,m,c) ->
  749. pr_orient b ++ spc() ++ pr_multi m ++ pr_with_bindings c)
  750. l
  751. ++ pr_clauses pr_ident cl
  752. ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt()))
  753. | TacInversion (DepInversion (k,c,ids),hyp) ->
  754. hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++
  755. pr_quantified_hypothesis hyp ++
  756. pr_with_inversion_names ids ++ pr_with_constr pr_constr c)
  757. | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
  758. hov 1 (pr_induction_kind k ++ spc () ++
  759. pr_quantified_hypothesis hyp ++
  760. pr_with_inversion_names ids ++ pr_simple_clause pr_ident cl)
  761. | TacInversion (InversionUsing (c,cl),hyp) ->
  762. hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++
  763. spc () ++ str "using" ++ spc () ++ pr_constr c ++
  764. pr_simple_clause pr_ident cl)
  765. in
  766. let rec pr_tac inherited tac =
  767. let (strm,prec) = match tac with
  768. | TacAbstract (t,None) ->
  769. str "abstract " ++ pr_tac (labstract,L) t, labstract
  770. | TacAbstract (t,Some s) ->
  771. hov 0
  772. (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++
  773. str "using " ++ pr_id s),
  774. labstract
  775. | TacLetIn (recflag,llc,u) ->
  776. let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in
  777. v 0
  778. (hv 0 (pr_let_clauses recflag (pr_tac ltop) llc ++ str " in") ++
  779. fnl () ++ pr_tac (llet,E) u),
  780. llet
  781. | TacMatch (lz,t,lrul) ->
  782. hov 0 (pr_lazy lz ++ str "match " ++ pr_tac ltop t ++ str " with"
  783. ++ prlist
  784. (fun r -> fnl () ++ str "| " ++
  785. pr_match_rule true (pr_tac ltop) pr_pat r)
  786. lrul
  787. ++ fnl() ++ str "end"),
  788. lmatch
  789. | TacMatchGoal (lz,lr,lrul) ->
  790. hov 0 (pr_lazy lz ++
  791. str (if lr then "match reverse goal with" else "match goal with")
  792. ++ prlist
  793. (fun r -> fnl () ++ str "| " ++
  794. pr_match_rule false (pr_tac ltop) pr_pat r)
  795. lrul
  796. ++ fnl() ++ str "end"),
  797. lmatch
  798. | TacFun (lvar,body) ->
  799. hov 2 (str "fun" ++
  800. prlist pr_funvar lvar ++ str " =>" ++ spc () ++
  801. pr_tac (lfun,E) body),
  802. lfun
  803. | TacThens (t,tl) ->
  804. hov 1 (pr_tac (lseq,E) t ++ pr_then () ++ spc () ++
  805. pr_seq_body (pr_tac ltop) tl),
  806. lseq
  807. | TacThen (t1,[||],t2,[||]) ->
  808. hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++
  809. pr_tac (lseq,L) t2),
  810. lseq
  811. | TacThen (t1,tf,t2,tl) ->
  812. hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++
  813. pr_then_gen (pr_tac ltop) tf t2 tl),
  814. lseq
  815. | TacTry t ->
  816. hov 1 (str "try" ++ spc () ++ pr_tac (ltactical,E) t),
  817. ltactical
  818. | TacDo (n,t) ->
  819. hov 1 (str "do " ++ pr_or_var int n ++ spc () ++
  820. pr_tac (ltactical,E) t),
  821. ltactical
  822. | TacRepeat t ->
  823. hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t),
  824. ltactical
  825. | TacProgress t ->
  826. hov 1 (str "progress" ++ spc () ++ pr_tac (ltactical,E) t),
  827. ltactical
  828. | TacInfo t ->
  829. hov 1 (str "info" ++ spc () ++ pr_tac (ltactical,E) t),
  830. linfo
  831. | TacOrelse (t1,t2) ->
  832. hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++
  833. pr_tac (lorelse,E) t2),
  834. lorelse
  835. | TacFail (n,l) ->
  836. str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
  837. prlist (pr_arg (pr_message_token pr_ident)) l, latom
  838. | TacFirst tl ->
  839. str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
  840. | TacSolve tl ->
  841. str "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
  842. | TacComplete t ->
  843. str "complete" ++ spc () ++ pr_tac (lcomplete,E) t, lcomplete
  844. | TacId l ->
  845. str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom
  846. | TacAtom (loc,TacAlias (_,s,l,_)) ->
  847. pr_with_comments loc
  848. (pr_extend (level_of inherited) s (List.map snd l)),
  849. latom
  850. | TacAtom (loc,t) ->
  851. pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom
  852. | TacArg(Tacexp e) -> pr_tac_level (latom,E) e, latom
  853. | TacArg(ConstrMayEval (ConstrTerm c)) ->
  854. str "constr:" ++ pr_constr c, latom
  855. | TacArg(ConstrMayEval c) ->
  856. pr_may_eval pr_constr pr_lconstr pr_cst c, leval
  857. | TacArg(TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom
  858. | TacArg(Integer n) -> int n, latom
  859. | TacArg(TacCall(loc,f,[])) -> pr_ref f, latom
  860. | TacArg(TacCall(loc,f,l)) ->
  861. pr_with_comments loc
  862. (hov 1 (pr_ref f ++ spc () ++
  863. prlist_with_sep spc pr_tacarg l)),
  864. lcall
  865. | TacArg a -> pr_tacarg a, latom
  866. in
  867. if prec_less prec inherited then strm
  868. else str"(" ++ strm ++ str")"
  869. and pr_tacarg = function
  870. | TacDynamic (loc,t) ->
  871. pr_with_comments loc (str ("<dynamic ["^(Dyn.tag t)^"]>"))
  872. | MetaIdArg (loc,true,s) -> pr_with_comments loc (str ("$" ^ s))
  873. | MetaIdArg (loc,false,s) -> pr_with_comments loc (str ("constr: $" ^ s))
  874. | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat
  875. | TacVoid -> str "()"
  876. | Reference r -> pr_ref r
  877. | ConstrMayEval c ->
  878. pr_may_eval pr_constr pr_lconstr pr_cst c
  879. | TacFreshId l -> str "fresh" ++ pr_fresh_ids l
  880. | TacExternal (_,com,req,la) ->
  881. str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++
  882. spc() ++ prlist_with_sep spc pr_tacarg la
  883. | (TacCall _|Tacexp _|Integer _) as a ->
  884. str "ltac:" ++ pr_tac (latom,E) (TacArg a)
  885. in (pr_tac, pr_match_rule)
  886. let strip_prod_binders_rawterm n (ty,_) =
  887. let rec strip_ty acc n ty =
  888. if n=0 then (List.rev acc, (ty,None)) else
  889. match ty with
  890. Rawterm.RProd(loc,na,Explicit,a,b) ->
  891. strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b
  892. | _ -> error "Cannot translate fix tactic: not enough products" in
  893. strip_ty [] n ty
  894. let strip_prod_binders_constr n (sigma,ty) =
  895. let rec strip_ty acc n ty =
  896. if n=0 then (List.rev acc, (sigma,ty)) else
  897. match Term.kind_of_term ty with
  898. Term.Prod(na,a,b) ->
  899. strip_ty (([dummy_loc,na],(sigma,a))::acc) (n-1) b
  900. | _ -> error "Cannot translate fix tactic: not enough products" in
  901. strip_ty [] n ty
  902. let drop_env f _env = f
  903. let rec raw_printers =
  904. (pr_raw_tactic_level,
  905. drop_env pr_constr_expr,
  906. drop_env pr_lconstr_expr,
  907. pr_lconstr_pattern_expr,
  908. drop_env (pr_or_by_notation pr_reference),
  909. drop_env (pr_or_by_notation pr_reference),
  910. pr_reference,
  911. pr_or_metaid pr_lident,
  912. pr_raw_extend,
  913. strip_prod_binders_expr)
  914. and pr_raw_tactic_level env n (t:raw_tactic_expr) =
  915. fst (make_pr_tac raw_printers env) n t
  916. and pr_raw_match_rule env t =
  917. snd (make_pr_tac raw_printers env) t
  918. let pr_and_constr_expr pr (c,_) = pr c
  919. let rec glob_printers =
  920. (pr_glob_tactic_level,
  921. (fun env -> pr_and_constr_expr (pr_rawconstr_env env)),
  922. (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)),
  923. (fun c -> pr_lconstr_pattern_env (Global.env()) c),
  924. (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
  925. (fun env -> pr_or_var (pr_inductive env)),
  926. pr_ltac_or_var (pr_located pr_ltac_constant),
  927. pr_lident,
  928. pr_glob_extend,
  929. strip_prod_binders_rawterm)
  930. and pr_glob_tactic_level env n (t:glob_tactic_expr) =
  931. fst (make_pr_tac glob_printers env) n t
  932. and pr_glob_match_rule env t =
  933. snd (make_pr_tac glob_printers env) t
  934. let typed_printers =
  935. (pr_glob_tactic_level,
  936. pr_open_constr_env,
  937. pr_open_lconstr_env,
  938. pr_lconstr_pattern,
  939. pr_evaluable_reference_env,
  940. pr_inductive,
  941. pr_ltac_constant,
  942. pr_id,
  943. pr_extend,
  944. strip_prod_binders_constr)
  945. let pr_tactic_level env = fst (make_pr_tac typed_printers env)
  946. let pr_raw_tactic env = pr_raw_tactic_level env ltop
  947. let pr_glob_tactic env = pr_glob_tactic_level env ltop
  948. let pr_tactic env = pr_tactic_level env ltop
  949. let _ = Tactic_debug.set_tactic_printer
  950. (fun x -> pr_glob_tactic (Global.env()) x)
  951. let _ = Tactic_debug.set_match_pattern_printer
  952. (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp)
  953. let _ = Tactic_debug.set_match_rule_printer
  954. (fun rl ->
  955. pr_match_rule false (pr_glob_tactic (Global.env())) pr_constr_pattern rl)
  956. open Pcoq
  957. let pr_tac_polymorphic n _ _ prtac = prtac (n,E)
  958. let _ = for i=0 to 5 do
  959. declare_extra_genarg_pprule
  960. (rawwit_tactic i, pr_tac_polymorphic i)
  961. (globwit_tactic i, pr_tac_polymorphic i)
  962. (wit_tactic i, pr_tac_polymorphic i)
  963. done