PageRenderTime 43ms CodeModel.GetById 11ms RepoModel.GetById 0ms app.codeStats 0ms

/parsing/ppconstr.ml

http://github.com/mzp/coq-ruby
OCaml | 756 lines | 644 code | 90 blank | 22 comment | 49 complexity | 707afcbeb43254ffac6e48535d8b4222 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: ppconstr.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
  9. (*i*)
  10. open Util
  11. open Pp
  12. open Nametab
  13. open Names
  14. open Nameops
  15. open Libnames
  16. open Ppextend
  17. open Topconstr
  18. open Term
  19. open Pattern
  20. open Rawterm
  21. open Constrextern
  22. open Termops
  23. (*i*)
  24. let sep_p = fun _ -> str"."
  25. let sep_v = fun _ -> str"," ++ spc()
  26. let sep_pp = fun _ -> str":"
  27. let sep_bar = fun _ -> spc() ++ str"| "
  28. let pr_tight_coma () = str "," ++ cut ()
  29. let latom = 0
  30. let lannot = 100
  31. let lprod = 200
  32. let llambda = 200
  33. let lif = 200
  34. let lletin = 200
  35. let lletpattern = 200
  36. let lfix = 200
  37. let larrow = 90
  38. let lcast = 100
  39. let larg = 9
  40. let lapp = 10
  41. let lposint = 0
  42. let lnegint = 35 (* must be consistent with Notation "- x" *)
  43. let ltop = (200,E)
  44. let lproj = 1
  45. let lsimple = (1,E)
  46. let prec_less child (parent,assoc) =
  47. if parent < 0 && child = lprod then true
  48. else
  49. let parent = abs parent in
  50. match assoc with
  51. | E -> (<=) child parent
  52. | L -> (<) child parent
  53. | Prec n -> child<=n
  54. | Any -> true
  55. let prec_of_prim_token = function
  56. | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint
  57. | String _ -> latom
  58. open Notation
  59. let print_hunks n pr (env,envlist) unp =
  60. let env = ref env and envlist = ref envlist in
  61. let pop r = let a = List.hd !r in r := List.tl !r; a in
  62. let rec aux = function
  63. | [] -> mt ()
  64. | UnpMetaVar (_,prec) :: l ->
  65. let c = pop env in pr (n,prec) c ++ aux l
  66. | UnpListMetaVar (_,prec,sl) :: l ->
  67. let cl = pop envlist in
  68. let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in
  69. let pp2 = aux l in
  70. pp1 ++ pp2
  71. | UnpTerminal s :: l -> str s ++ aux l
  72. | UnpBox (b,sub) :: l ->
  73. (* Keep order: side-effects *)
  74. let pp1 = ppcmd_of_box b (aux sub) in
  75. let pp2 = aux l in
  76. pp1 ++ pp2
  77. | UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in
  78. aux unp
  79. let pr_notation pr s env =
  80. let unpl, level = find_notation_printing_rule s in
  81. print_hunks level pr env unpl, level
  82. let pr_delimiters key strm =
  83. strm ++ str ("%"^key)
  84. let pr_generalization bk ak c =
  85. let hd, tl =
  86. match bk with
  87. | Implicit -> "{", "}"
  88. | Explicit -> "(", ")"
  89. in (* TODO: syntax Abstraction Kind *)
  90. str "`" ++ str hd ++ c ++ str tl
  91. let pr_com_at n =
  92. if Flags.do_beautify() && n <> 0 then comment n
  93. else mt()
  94. let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
  95. let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
  96. let pr_optc pr = function
  97. | None -> mt ()
  98. | Some x -> pr_sep_com spc pr x
  99. let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
  100. let pr_universe = Univ.pr_uni
  101. let pr_rawsort = function
  102. | RProp Term.Null -> str "Prop"
  103. | RProp Term.Pos -> str "Set"
  104. | RType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u)
  105. let pr_id = pr_id
  106. let pr_name = pr_name
  107. let pr_qualid = pr_qualid
  108. let pr_expl_args pr (a,expl) =
  109. match expl with
  110. | None -> pr (lapp,L) a
  111. | Some (_,ExplByPos (n,_id)) ->
  112. anomaly("Explicitation by position not implemented")
  113. | Some (_,ExplByName id) ->
  114. str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
  115. let pr_opt_type pr = function
  116. | CHole _ -> mt ()
  117. | t -> cut () ++ str ":" ++ pr t
  118. let pr_opt_type_spc pr = function
  119. | CHole _ -> mt ()
  120. | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
  121. let pr_lident (loc,id) =
  122. if loc <> dummy_loc then
  123. let (b,_) = unloc loc in
  124. pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
  125. else pr_id id
  126. let pr_lname = function
  127. (loc,Name id) -> pr_lident (loc,id)
  128. | lna -> pr_located pr_name lna
  129. let pr_or_var pr = function
  130. | ArgArg x -> pr x
  131. | ArgVar (loc,s) -> pr_lident (loc,s)
  132. let pr_prim_token = function
  133. | Numeral n -> Bigint.pr_bigint n
  134. | String s -> qs s
  135. let pr_evar pr n l =
  136. hov 0 (str (Evd.string_of_existential n) ++
  137. (match l with
  138. | Some l ->
  139. spc () ++ pr_in_comment
  140. (fun l ->
  141. str"[" ++ hov 0 (prlist_with_sep pr_coma (pr ltop) l) ++ str"]")
  142. (List.rev l)
  143. | None -> mt()))
  144. let las = lapp
  145. let lpator = 100
  146. let rec pr_patt sep inh p =
  147. let (strm,prec) = match p with
  148. | CPatAlias (_,p,id) ->
  149. pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
  150. | CPatCstr (_,c,[]) -> pr_reference c, latom
  151. | CPatCstr (_,c,args) ->
  152. pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
  153. | CPatAtom (_,None) -> str "_", latom
  154. | CPatAtom (_,Some r) -> pr_reference r, latom
  155. | CPatOr (_,pl) ->
  156. hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
  157. | CPatNotation (_,"( _ )",([p],[])) ->
  158. pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
  159. | CPatNotation (_,s,env) -> pr_notation (pr_patt mt) s env
  160. | CPatPrim (_,p) -> pr_prim_token p, latom
  161. | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1
  162. in
  163. let loc = cases_pattern_expr_loc p in
  164. pr_with_comments loc
  165. (sep() ++ if prec_less prec inh then strm else surround strm)
  166. let pr_patt = pr_patt mt
  167. let pr_eqn pr (loc,pl,rhs) =
  168. let pl = List.map snd pl in
  169. spc() ++ hov 4
  170. (pr_with_comments loc
  171. (str "| " ++
  172. hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl
  173. ++ str " =>") ++
  174. pr_sep_com spc (pr ltop) rhs))
  175. let begin_of_binder = function
  176. LocalRawDef((loc,_),_) -> fst (unloc loc)
  177. | LocalRawAssum((loc,_)::_,_,_) -> fst (unloc loc)
  178. | _ -> assert false
  179. let begin_of_binders = function
  180. | b::_ -> begin_of_binder b
  181. | _ -> 0
  182. let surround_impl k p =
  183. match k with
  184. | Explicit -> str"(" ++ p ++ str")"
  185. | Implicit -> str"{" ++ p ++ str"}"
  186. let surround_binder k p =
  187. match k with
  188. | Default b -> hov 1 (surround_impl b p)
  189. | Generalized (b, b', t) ->
  190. hov 1 (surround_impl b' (surround_impl b p))
  191. let surround_implicit k p =
  192. match k with
  193. | Default Explicit -> p
  194. | Default Implicit -> (str"{" ++ p ++ str"}")
  195. | Generalized (b, b', t) ->
  196. surround_impl b' (surround_impl b p)
  197. let pr_binder many pr (nal,k,t) =
  198. match t with
  199. | CHole _ -> prlist_with_sep spc pr_lname nal
  200. | _ ->
  201. let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in
  202. hov 1 (if many then surround_binder k s else surround_implicit k s)
  203. let pr_binder_among_many pr_c = function
  204. | LocalRawAssum (nal,k,t) ->
  205. pr_binder true pr_c (nal,k,t)
  206. | LocalRawDef (na,c) ->
  207. let c,topt = match c with
  208. | CCast(_,c, CastConv (_,t)) -> c, t
  209. | _ -> c, CHole (dummy_loc, None) in
  210. hov 1 (pr_lname na ++ pr_opt_type pr_c topt ++
  211. str":=" ++ cut() ++ pr_c c)
  212. let pr_undelimited_binders pr_c =
  213. prlist_with_sep spc (pr_binder_among_many pr_c)
  214. let pr_delimited_binders kw pr_c bl =
  215. let n = begin_of_binders bl in
  216. match bl with
  217. | [LocalRawAssum (nal,k,t)] ->
  218. pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t)
  219. | LocalRawAssum _ :: _ as bdl ->
  220. pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl
  221. | _ -> assert false
  222. let rec extract_prod_binders = function
  223. (* | CLetIn (loc,na,b,c) as x ->
  224. let bl,c = extract_prod_binders c in
  225. if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
  226. | CProdN (loc,[],c) ->
  227. extract_prod_binders c
  228. | CProdN (loc,(nal,bk,t)::bl,c) ->
  229. let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
  230. LocalRawAssum (nal,bk,t) :: bl, c
  231. | c -> [], c
  232. let rec extract_lam_binders = function
  233. (* | CLetIn (loc,na,b,c) as x ->
  234. let bl,c = extract_lam_binders c in
  235. if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
  236. | CLambdaN (loc,[],c) ->
  237. extract_lam_binders c
  238. | CLambdaN (loc,(nal,bk,t)::bl,c) ->
  239. let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
  240. LocalRawAssum (nal,bk,t) :: bl, c
  241. | c -> [], c
  242. let split_lambda = function
  243. | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c)
  244. | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
  245. | CLambdaN (loc,(na::nal,bk,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,bk,t)::bl,c))
  246. | _ -> anomaly "ill-formed fixpoint body"
  247. let rename na na' t c =
  248. match (na,na') with
  249. | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c)
  250. | (_,Name id), (_,Anonymous) -> (na,t,c)
  251. | _ -> (na',t,c)
  252. let split_product na' = function
  253. | CArrow (loc,t,c) -> (na',t,c)
  254. | CProdN (loc,[[na],bk,t],c) -> rename na na' t c
  255. | CProdN (loc,([na],bk,t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
  256. | CProdN (loc,(na::nal,bk,t)::bl,c) ->
  257. rename na na' t (CProdN(loc,(nal,bk,t)::bl,c))
  258. | _ -> anomaly "ill-formed fixpoint body"
  259. let merge_binders (na1,bk1,ty1) cofun (na2,bk2,ty2) codom =
  260. let na =
  261. match snd na1, snd na2 with
  262. Anonymous, Name id ->
  263. if occur_var_constr_expr id cofun then
  264. failwith "avoid capture"
  265. else na2
  266. | Name id, Anonymous ->
  267. if occur_var_constr_expr id codom then
  268. failwith "avoid capture"
  269. else na1
  270. | Anonymous, Anonymous -> na1
  271. | Name id1, Name id2 ->
  272. if id1 <> id2 then failwith "not same name" else na1 in
  273. let ty =
  274. match ty1, ty2 with
  275. CHole _, _ -> ty2
  276. | _, CHole _ -> ty1
  277. | _ ->
  278. Constrextern.check_same_type ty1 ty2;
  279. ty2 in
  280. (LocalRawAssum ([na],bk1,ty), codom)
  281. let rec strip_domain bvar cofun c =
  282. match c with
  283. | CArrow(loc,a,b) ->
  284. merge_binders bvar cofun ((dummy_loc,Anonymous),default_binder_kind,a) b
  285. | CProdN(loc,[([na],bk,ty)],c') ->
  286. merge_binders bvar cofun (na,bk,ty) c'
  287. | CProdN(loc,([na],bk,ty)::bl,c') ->
  288. merge_binders bvar cofun (na,bk,ty) (CProdN(loc,bl,c'))
  289. | CProdN(loc,(na::nal,bk,ty)::bl,c') ->
  290. merge_binders bvar cofun (na,bk,ty) (CProdN(loc,(nal,bk,ty)::bl,c'))
  291. | _ -> failwith "not a product"
  292. (* Note: binder sharing is lost *)
  293. let rec strip_domains (nal,bk,ty) cofun c =
  294. match nal with
  295. [] -> assert false
  296. | [na] ->
  297. let bnd, c' = strip_domain (na,bk,ty) cofun c in
  298. ([bnd],None,c')
  299. | na::nal ->
  300. let f = CLambdaN(dummy_loc,[(nal,bk,ty)],cofun) in
  301. let bnd, c1 = strip_domain (na,bk,ty) f c in
  302. (try
  303. let bl, rest, c2 = strip_domains (nal,bk,ty) cofun c1 in
  304. (bnd::bl, rest, c2)
  305. with Failure _ -> ([bnd],Some (nal,bk,ty), c1))
  306. (* Re-share binders *)
  307. let rec factorize_binders = function
  308. | ([] | [_] as l) -> l
  309. | LocalRawAssum (nal,k,ty) as d :: (LocalRawAssum (nal',k',ty')::l as l') ->
  310. (try
  311. let _ = Constrextern.check_same_type ty ty' in
  312. factorize_binders (LocalRawAssum (nal@nal',k,ty)::l)
  313. with _ ->
  314. d :: factorize_binders l')
  315. | d :: l -> d :: factorize_binders l
  316. (* Extract lambdas when a type constraint occurs *)
  317. let rec extract_def_binders c ty =
  318. match c with
  319. | CLambdaN(loc,bvar::lams,b) ->
  320. (try
  321. let f = CLambdaN(loc,lams,b) in
  322. let bvar', rest, ty' = strip_domains bvar f ty in
  323. let c' =
  324. match rest, lams with
  325. None,[] -> b
  326. | None, _ -> f
  327. | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in
  328. let (bl,c2,ty2) = extract_def_binders c' ty' in
  329. (factorize_binders (bvar'@bl), c2, ty2)
  330. with Failure _ ->
  331. ([],c,ty))
  332. | _ -> ([],c,ty)
  333. let rec split_fix n typ def =
  334. if n = 0 then ([],typ,def)
  335. else
  336. let (na,_,def) = split_lambda def in
  337. let (na,t,typ) = split_product na typ in
  338. let (bl,typ,def) = split_fix (n-1) typ def in
  339. (LocalRawAssum ([na],default_binder_kind,t)::bl,typ,def)
  340. let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
  341. let pr_body =
  342. if dangling_with_for then pr_dangling else pr in
  343. pr_id id ++ str" " ++
  344. hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++
  345. pr_opt_type_spc pr t ++ str " :=" ++
  346. pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
  347. let pr_fixdecl pr prd dangling_with_for ((_,id),(n,ro),bl,t,c) =
  348. let annot =
  349. match ro with
  350. CStructRec ->
  351. if List.length bl > 1 && n <> None then
  352. spc() ++ str "{struct " ++ pr_id (snd (Option.get n)) ++ str"}"
  353. else mt()
  354. | CWfRec c ->
  355. spc () ++ str "{wf " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}"
  356. | CMeasureRec c ->
  357. spc () ++ str "{measure " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}"
  358. in
  359. pr_recursive_decl pr prd dangling_with_for id bl annot t c
  360. let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) =
  361. pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
  362. let pr_recursive pr_decl id = function
  363. | [] -> anomaly "(co)fixpoint with no definition"
  364. | [d1] -> pr_decl false d1
  365. | dl ->
  366. prlist_with_sep (fun () -> fnl() ++ str "with ")
  367. (pr_decl true) dl ++
  368. fnl() ++ str "for " ++ pr_id id
  369. let is_var id = function
  370. | CRef (Ident (_,id')) when id=id' -> true
  371. | _ -> false
  372. let tm_clash = function
  373. | (CRef (Ident (_,id)), Some (CApp (_,_,nal)))
  374. when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false)
  375. nal
  376. -> Some id
  377. | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal)))
  378. when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false)
  379. nal
  380. -> Some id
  381. | _ -> None
  382. let pr_asin pr (na,indnalopt) =
  383. (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
  384. | Some na -> spc () ++ str "as " ++ pr_name na
  385. | None -> mt ()) ++
  386. (match indnalopt with
  387. | None -> mt ()
  388. | Some t -> spc () ++ str "in " ++ pr lsimple t)
  389. let pr_case_item pr (tm,asin) =
  390. hov 0 (pr (lcast,E) tm ++ pr_asin pr asin)
  391. let pr_case_type pr po =
  392. match po with
  393. | None | Some (CHole _) -> mt()
  394. | Some p ->
  395. spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p)
  396. let pr_return_type pr po = pr_case_type pr po
  397. let pr_simple_return_type pr na po =
  398. (match na with
  399. | Some (Name id) ->
  400. spc () ++ str "as " ++ pr_id id
  401. | _ -> mt ()) ++
  402. pr_case_type pr po
  403. let pr_proj pr pr_app a f l =
  404. hov 0 (pr lsimple a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
  405. let pr_appexpl pr f l =
  406. hov 2 (
  407. str "@" ++ pr_reference f ++
  408. prlist (pr_sep_com spc (pr (lapp,L))) l)
  409. let pr_app pr a l =
  410. hov 2 (
  411. pr (lapp,L) a ++
  412. prlist (fun a -> spc () ++ pr_expl_args pr a) l)
  413. let pr_forall () =
  414. if !Flags.unicode_syntax then str"Π" ++ spc ()
  415. else str"forall" ++ spc ()
  416. let pr_fun () =
  417. if !Flags.unicode_syntax then str"λ" ++ spc ()
  418. else str"fun" ++ spc ()
  419. let pr_fun_sep = lazy (if !Flags.unicode_syntax then str "," else str " =>")
  420. let rec pr sep inherited a =
  421. let (strm,prec) = match a with
  422. | CRef r -> pr_reference r, latom
  423. | CFix (_,id,fix) ->
  424. hov 0 (str"fix " ++
  425. pr_recursive
  426. (pr_fixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) fix),
  427. lfix
  428. | CCoFix (_,id,cofix) ->
  429. hov 0 (str "cofix " ++
  430. pr_recursive
  431. (pr_cofixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) cofix),
  432. lfix
  433. | CArrow (_,a,b) ->
  434. hov 0 (pr mt (larrow,L) a ++ str " ->" ++
  435. pr (fun () ->brk(1,0)) (-larrow,E) b),
  436. larrow
  437. | CProdN _ ->
  438. let (bl,a) = extract_prod_binders a in
  439. hov 0 (
  440. hov 2 (pr_delimited_binders pr_forall
  441. (pr mt ltop) bl) ++
  442. str "," ++ pr spc ltop a),
  443. lprod
  444. | CLambdaN _ ->
  445. let (bl,a) = extract_lam_binders a in
  446. hov 0 (
  447. hov 2 (pr_delimited_binders pr_fun
  448. (pr mt ltop) bl) ++
  449. Lazy.force pr_fun_sep ++ pr spc ltop a),
  450. llambda
  451. | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
  452. when x=x' ->
  453. hv 0 (
  454. hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++
  455. pr spc ltop b),
  456. lletin
  457. | CLetIn (_,x,a,b) ->
  458. hv 0 (
  459. hov 2 (str "let " ++ pr_lname x ++ str " :=" ++
  460. pr spc ltop a ++ str " in") ++
  461. pr spc ltop b),
  462. lletin
  463. | CAppExpl (_,(Some i,f),l) ->
  464. let l1,l2 = list_chop i l in
  465. let c,l1 = list_sep_last l1 in
  466. let p = pr_proj (pr mt) pr_appexpl c f l1 in
  467. if l2<>[] then
  468. p ++ prlist (pr spc (lapp,L)) l2, lapp
  469. else
  470. p, lproj
  471. | CAppExpl (_,(None,Ident (_,var)),[t])
  472. | CApp (_,(_,CRef(Ident(_,var))),[t,None])
  473. when var = Topconstr.ldots_var ->
  474. hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg
  475. | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp
  476. | CApp (_,(Some i,f),l) ->
  477. let l1,l2 = list_chop i l in
  478. let c,l1 = list_sep_last l1 in
  479. assert (snd c = None);
  480. let p = pr_proj (pr mt) pr_app (fst c) f l1 in
  481. if l2<>[] then
  482. p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp
  483. else
  484. p, lproj
  485. | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp
  486. | CRecord (_,w,l) ->
  487. let beg =
  488. match w with
  489. | None -> spc ()
  490. | Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc ()
  491. in
  492. hv 0 (str"{" ++ beg ++
  493. prlist_with_sep (fun () -> spc () ++ str";" ++ spc ())
  494. (fun ((_,id), c) -> pr_id id ++ spc () ++ str":=" ++ spc () ++ pr spc ltop c)
  495. l), latom
  496. | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) ->
  497. hv 0 (
  498. str "let '" ++
  499. hov 0 (pr_patt ltop p ++
  500. pr_asin (pr_dangling_with_for mt) asin ++
  501. str " :=" ++ pr spc ltop c ++
  502. pr_case_type (pr_dangling_with_for mt) rtntypopt ++
  503. str " in" ++ pr spc ltop b)),
  504. lletpattern
  505. | CCases(_,_,rtntypopt,c,eqns) ->
  506. v 0
  507. (hv 0 (str "match" ++ brk (1,2) ++
  508. hov 0 (
  509. prlist_with_sep sep_v
  510. (pr_case_item (pr_dangling_with_for mt)) c
  511. ++ pr_case_type (pr_dangling_with_for mt) rtntypopt) ++
  512. spc () ++ str "with") ++
  513. prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"),
  514. latom
  515. | CLetTuple (_,nal,(na,po),c,b) ->
  516. hv 0 (
  517. str "let " ++
  518. hov 0 (str "(" ++
  519. prlist_with_sep sep_v pr_name nal ++
  520. str ")" ++
  521. pr_simple_return_type (pr mt) na po ++ str " :=" ++
  522. pr spc ltop c ++ str " in") ++
  523. pr spc ltop b),
  524. lletin
  525. | CIf (_,c,(na,po),b1,b2) ->
  526. (* On force les parenthèses autour d'un "if" sous-terme (même si le
  527. parsing est lui plus tolérant) *)
  528. hv 0 (
  529. hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++
  530. spc () ++
  531. hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
  532. hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
  533. lif
  534. | CHole _ -> str "_", latom
  535. | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom
  536. | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
  537. | CSort (_,s) -> pr_rawsort s, latom
  538. | CCast (_,a,CastConv (k,b)) ->
  539. let s = match k with VMcast -> "<:" | DEFAULTcast -> ":" in
  540. hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b),
  541. lcast
  542. | CCast (_,a,CastCoerce) ->
  543. hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"),
  544. lcast
  545. | CNotation (_,"( _ )",([t],[])) ->
  546. pr (fun()->str"(") (max_int,L) t ++ str")", latom
  547. | CNotation (_,s,env) -> pr_notation (pr mt) s env
  548. | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom
  549. | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
  550. | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
  551. | CDynamic _ -> str "<dynamic>", latom
  552. in
  553. let loc = constr_loc a in
  554. pr_with_comments loc
  555. (sep() ++ if prec_less prec inherited then strm else surround strm)
  556. and pr_dangling_with_for sep inherited a =
  557. match a with
  558. | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
  559. | _ -> pr sep inherited a
  560. let pr = pr mt
  561. let rec strip_context n iscast t =
  562. if n = 0 then
  563. [], if iscast then match t with CCast (_,c,_) -> c | _ -> t else t
  564. else match t with
  565. | CLambdaN (loc,(nal,bk,t)::bll,c) ->
  566. let n' = List.length nal in
  567. if n' > n then
  568. let nal1,nal2 = list_chop n nal in
  569. [LocalRawAssum (nal1,bk,t)], CLambdaN (loc,(nal2,bk,t)::bll,c)
  570. else
  571. let bl', c = strip_context (n-n') iscast
  572. (if bll=[] then c else CLambdaN (loc,bll,c)) in
  573. LocalRawAssum (nal,bk,t) :: bl', c
  574. | CProdN (loc,(nal,bk,t)::bll,c) ->
  575. let n' = List.length nal in
  576. if n' > n then
  577. let nal1,nal2 = list_chop n nal in
  578. [LocalRawAssum (nal1,bk,t)], CProdN (loc,(nal2,bk,t)::bll,c)
  579. else
  580. let bl', c = strip_context (n-n') iscast
  581. (if bll=[] then c else CProdN (loc,bll,c)) in
  582. LocalRawAssum (nal,bk,t) :: bl', c
  583. | CArrow (loc,t,c) ->
  584. let bl', c = strip_context (n-1) iscast c in
  585. LocalRawAssum ([loc,Anonymous],default_binder_kind,t) :: bl', c
  586. | CCast (_,c,_) -> strip_context n false c
  587. | CLetIn (_,na,b,c) ->
  588. let bl', c = strip_context (n-1) iscast c in
  589. LocalRawDef (na,b) :: bl', c
  590. | _ -> anomaly "strip_context"
  591. type term_pr = {
  592. pr_constr_expr : constr_expr -> std_ppcmds;
  593. pr_lconstr_expr : constr_expr -> std_ppcmds;
  594. pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds;
  595. pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
  596. }
  597. let default_term_pr = {
  598. pr_constr_expr = pr lsimple;
  599. pr_lconstr_expr = pr ltop;
  600. pr_constr_pattern_expr = pr lsimple;
  601. pr_lconstr_pattern_expr = pr ltop
  602. }
  603. let term_pr = ref default_term_pr
  604. let set_term_pr = (:=) term_pr
  605. let pr_constr_expr c = !term_pr.pr_constr_expr c
  606. let pr_lconstr_expr c = !term_pr.pr_lconstr_expr c
  607. let pr_constr_pattern_expr c = !term_pr.pr_constr_pattern_expr c
  608. let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c
  609. let pr_cases_pattern_expr = pr_patt ltop
  610. let pr_binders = pr_undelimited_binders (pr ltop)
  611. let pr_with_occurrences_with_trailer pr occs trailer =
  612. match occs with
  613. ((false,[]),c) -> pr c ++ trailer
  614. | ((nowhere_except_in,nl),c) ->
  615. hov 1 (pr c ++ spc() ++ str"at " ++
  616. (if nowhere_except_in then mt() else str "- ") ++
  617. hov 0 (prlist_with_sep spc (pr_or_var int) nl) ++ trailer)
  618. let pr_with_occurrences pr occs =
  619. pr_with_occurrences_with_trailer pr occs (mt())
  620. let pr_red_flag pr r =
  621. (if r.rBeta then pr_arg str "beta" else mt ()) ++
  622. (if r.rIota then pr_arg str "iota" else mt ()) ++
  623. (if r.rZeta then pr_arg str "zeta" else mt ()) ++
  624. (if r.rConst = [] then
  625. if r.rDelta then pr_arg str "delta"
  626. else mt ()
  627. else
  628. pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
  629. hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
  630. open Genarg
  631. let pr_metaid id = str"?" ++ pr_id id
  632. let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function
  633. | Red false -> str "red"
  634. | Hnf -> str "hnf"
  635. | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_constr) o
  636. | Cbv f ->
  637. if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
  638. str "compute"
  639. else
  640. hov 1 (str "cbv" ++ pr_red_flag pr_ref f)
  641. | Lazy f ->
  642. hov 1 (str "lazy" ++ pr_red_flag pr_ref f)
  643. | Unfold l ->
  644. hov 1 (str "unfold" ++ spc() ++
  645. prlist_with_sep pr_coma (pr_with_occurrences pr_ref) l)
  646. | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l)
  647. | Pattern l ->
  648. hov 1 (str "pattern" ++
  649. pr_arg (prlist_with_sep pr_coma (pr_with_occurrences pr_constr)) l)
  650. | Red true -> error "Shouldn't be accessible from user."
  651. | ExtraRedExpr s -> str s
  652. | CbvVm -> str "vm_compute"
  653. let rec pr_may_eval test prc prlc pr2 = function
  654. | ConstrEval (r,c) ->
  655. hov 0
  656. (str "eval" ++ brk (1,1) ++
  657. pr_red_expr (prc,prlc,pr2) r ++
  658. str " in" ++ spc() ++ prc c)
  659. | ConstrContext ((_,id),c) ->
  660. hov 0
  661. (str "context " ++ pr_id id ++ spc () ++
  662. str "[" ++ prlc c ++ str "]")
  663. | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c)
  664. | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")")
  665. | ConstrTerm c -> prc c
  666. let pr_may_eval a = pr_may_eval (fun _ -> false) a