PageRenderTime 85ms CodeModel.GetById 16ms RepoModel.GetById 0ms app.codeStats 1ms

/toplevel/himsg.ml

http://github.com/mzp/coq-ruby
OCaml | 826 lines | 701 code | 96 blank | 29 comment | 21 complexity | 0a2244b9debbf132e412eb6a8507eae2 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: himsg.ml 11986 2009-03-17 11:44:20Z herbelin $ *)
  9. open Pp
  10. open Util
  11. open Flags
  12. open Names
  13. open Nameops
  14. open Term
  15. open Termops
  16. open Inductive
  17. open Indtypes
  18. open Sign
  19. open Environ
  20. open Pretype_errors
  21. open Type_errors
  22. open Typeclasses_errors
  23. open Indrec
  24. open Reduction
  25. open Cases
  26. open Logic
  27. open Printer
  28. open Rawterm
  29. open Evd
  30. let pr_lconstr c = quote (pr_lconstr c)
  31. let pr_lconstr_env e c = quote (pr_lconstr_env e c)
  32. let pr_lconstr_env_at_top e c = quote (pr_lconstr_env_at_top e c)
  33. let pr_ljudge_env e c = let v,t = pr_ljudge_env e c in (quote v,quote t)
  34. let pr_db env i =
  35. try
  36. match lookup_rel i env with
  37. Name id, _, _ -> pr_id id
  38. | Anonymous, _, _ -> str "<>"
  39. with Not_found -> str "UNBOUND_REL_" ++ int i
  40. let explain_unbound_rel env n =
  41. let pe = pr_ne_context_of (str "In environment") env in
  42. str "Unbound reference: " ++ pe ++
  43. str "The reference " ++ int n ++ str " is free."
  44. let explain_unbound_var env v =
  45. let var = pr_id v in
  46. str "No such section variable or assumption: " ++ var ++ str "."
  47. let explain_not_type env j =
  48. let pe = pr_ne_context_of (str "In environment") env in
  49. let pc,pt = pr_ljudge_env env j in
  50. pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++
  51. str "has type" ++ spc () ++ pt ++ spc () ++
  52. str "which should be Set, Prop or Type."
  53. let explain_bad_assumption env j =
  54. let pe = pr_ne_context_of (str "In environment") env in
  55. let pc,pt = pr_ljudge_env env j in
  56. pe ++ str "Cannot declare a variable or hypothesis over the term" ++
  57. brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++
  58. str "because this term is not a type."
  59. let explain_reference_variables c =
  60. let pc = pr_lconstr c in
  61. str "The constant" ++ spc () ++ pc ++ spc () ++
  62. str "refers to variables which are not in the context."
  63. let rec pr_disjunction pr = function
  64. | [a] -> pr a
  65. | [a;b] -> pr a ++ str " or" ++ spc () ++ pr b
  66. | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l
  67. | [] -> assert false
  68. let explain_elim_arity env ind sorts c pj okinds =
  69. let env = make_all_name_different env in
  70. let pi = pr_inductive env ind in
  71. let pc = pr_lconstr_env env c in
  72. let msg = match okinds with
  73. | Some(kp,ki,explanation) ->
  74. let pki = pr_sort_family ki in
  75. let pkp = pr_sort_family kp in
  76. let explanation = match explanation with
  77. | NonInformativeToInformative ->
  78. "proofs can be eliminated only to build proofs"
  79. | StrongEliminationOnNonSmallType ->
  80. "strong elimination on non-small inductive types leads to paradoxes"
  81. | WrongArity ->
  82. "wrong arity" in
  83. let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in
  84. let ppt = pr_lconstr_env env (snd (decompose_prod_assum pj.uj_type)) in
  85. hov 0
  86. (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++
  87. str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++
  88. fnl () ++
  89. hov 0
  90. (str "Elimination of an inductive object of sort " ++
  91. pki ++ brk(1,0) ++
  92. str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++
  93. str "because" ++ spc () ++ str explanation ++ str ".")
  94. | None ->
  95. str "ill-formed elimination predicate."
  96. in
  97. hov 0 (
  98. str "Incorrect elimination of" ++ spc () ++ pc ++ spc () ++
  99. str "in the inductive type" ++ spc () ++ quote pi ++ str ":") ++
  100. fnl () ++ msg
  101. let explain_case_not_inductive env cj =
  102. let env = make_all_name_different env in
  103. let pc = pr_lconstr_env env cj.uj_val in
  104. let pct = pr_lconstr_env env cj.uj_type in
  105. match kind_of_term cj.uj_type with
  106. | Evar _ ->
  107. str "Cannot infer a type for this expression."
  108. | _ ->
  109. str "The term" ++ brk(1,1) ++ pc ++ spc () ++
  110. str "has type" ++ brk(1,1) ++ pct ++ spc () ++
  111. str "which is not a (co-)inductive type."
  112. let explain_number_branches env cj expn =
  113. let env = make_all_name_different env in
  114. let pc = pr_lconstr_env env cj.uj_val in
  115. let pct = pr_lconstr_env env cj.uj_type in
  116. str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++
  117. str "of type" ++ brk(1,1) ++ pct ++ spc () ++
  118. str "expects " ++ int expn ++ str " branches."
  119. let explain_ill_formed_branch env c i actty expty =
  120. let env = make_all_name_different env in
  121. let pc = pr_lconstr_env env c in
  122. let pa = pr_lconstr_env env actty in
  123. let pe = pr_lconstr_env env expty in
  124. str "In pattern-matching on term" ++ brk(1,1) ++ pc ++
  125. spc () ++ str "the " ++ nth (i+1) ++ str " branch has type" ++
  126. brk(1,1) ++ pa ++ spc () ++
  127. str "which should be" ++ brk(1,1) ++ pe ++ str "."
  128. let explain_generalization env (name,var) j =
  129. let pe = pr_ne_context_of (str "In environment") env in
  130. let pv = pr_ltype_env env var in
  131. let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) j in
  132. pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
  133. str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++
  134. str "it has type" ++ spc () ++ pt ++
  135. spc () ++ str "which should be Set, Prop or Type."
  136. let explain_actual_type env j pt =
  137. let pe = pr_ne_context_of (str "In environment") env in
  138. let (pc,pct) = pr_ljudge_env env j in
  139. let pt = pr_lconstr_env env pt in
  140. pe ++
  141. str "The term" ++ brk(1,1) ++ pc ++ spc () ++
  142. str "has type" ++ brk(1,1) ++ pct ++ brk(1,1) ++
  143. str "while it is expected to have type" ++ brk(1,1) ++ pt ++ str "."
  144. let explain_cant_apply_bad_type env (n,exptyp,actualtyp) rator randl =
  145. let env = make_all_name_different env in
  146. let nargs = Array.length randl in
  147. (* let pe = pr_ne_context_of (str "in environment") env in*)
  148. let pr,prt = pr_ljudge_env env rator in
  149. let term_string1 = str (plural nargs "term") in
  150. let term_string2 =
  151. if nargs>1 then str "The " ++ nth n ++ str " term" else str "This term" in
  152. let appl = prvect_with_sep pr_fnl
  153. (fun c ->
  154. let pc,pct = pr_ljudge_env env c in
  155. hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
  156. in
  157. str "Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++
  158. str "The term" ++ brk(1,1) ++ pr ++ spc () ++
  159. str "of type" ++ brk(1,1) ++ prt ++ spc () ++
  160. str "cannot be applied to the " ++ term_string1 ++ fnl () ++
  161. str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++
  162. brk(1,1) ++ pr_lconstr_env env actualtyp ++ spc () ++
  163. str "which should be coercible to" ++ brk(1,1) ++
  164. pr_lconstr_env env exptyp ++ str "."
  165. let explain_cant_apply_not_functional env rator randl =
  166. let env = make_all_name_different env in
  167. let nargs = Array.length randl in
  168. (* let pe = pr_ne_context_of (str "in environment") env in*)
  169. let pr = pr_lconstr_env env rator.uj_val in
  170. let prt = pr_lconstr_env env rator.uj_type in
  171. let appl = prvect_with_sep pr_fnl
  172. (fun c ->
  173. let pc = pr_lconstr_env env c.uj_val in
  174. let pct = pr_lconstr_env env c.uj_type in
  175. hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
  176. in
  177. str "Illegal application (Non-functional construction): " ++
  178. (* pe ++ *) fnl () ++
  179. str "The expression" ++ brk(1,1) ++ pr ++ spc () ++
  180. str "of type" ++ brk(1,1) ++ prt ++ spc () ++
  181. str "cannot be applied to the " ++ str (plural nargs "term") ++ fnl () ++
  182. str " " ++ v 0 appl
  183. let explain_unexpected_type env actual_type expected_type =
  184. let pract = pr_lconstr_env env actual_type in
  185. let prexp = pr_lconstr_env env expected_type in
  186. str "This type is" ++ spc () ++ pract ++ spc () ++
  187. str "but is expected to be" ++
  188. spc () ++ prexp ++ str "."
  189. let explain_not_product env c =
  190. let pr = pr_lconstr_env env c in
  191. str "The type of this term is a product" ++ spc () ++
  192. str "while it is expected to be" ++
  193. (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
  194. (* TODO: use the names *)
  195. (* (co)fixpoints *)
  196. let explain_ill_formed_rec_body env err names i fixenv vdefj =
  197. let prt_name i =
  198. match names.(i) with
  199. Name id -> str "Recursive definition of " ++ pr_id id
  200. | Anonymous -> str "The " ++ nth i ++ str " definition" in
  201. let st = match err with
  202. (* Fixpoint guard errors *)
  203. | NotEnoughAbstractionInFixBody ->
  204. str "Not enough abstractions in the definition"
  205. | RecursionNotOnInductiveType c ->
  206. str "Recursive definition on" ++ spc () ++ pr_lconstr_env env c ++ spc () ++
  207. str "which should be an inductive type"
  208. | RecursionOnIllegalTerm(j,arg,le,lt) ->
  209. let called =
  210. match names.(j) with
  211. Name id -> pr_id id
  212. | Anonymous -> str "the " ++ nth i ++ str " definition" in
  213. let vars =
  214. match (lt,le) with
  215. ([],[]) -> assert false
  216. | ([],[x]) ->
  217. str "a subterm of " ++ pr_db env x
  218. | ([],_) ->
  219. str "a subterm of the following variables: " ++
  220. prlist_with_sep pr_spc (pr_db env) le
  221. | ([x],_) -> pr_db env x
  222. | _ ->
  223. str "one of the following variables: " ++
  224. prlist_with_sep pr_spc (pr_db env) lt in
  225. str "Recursive call to " ++ called ++ spc () ++
  226. str "has principal argument equal to" ++ spc () ++
  227. pr_lconstr_env env arg ++ fnl () ++ str "instead of " ++ vars
  228. | NotEnoughArgumentsForFixCall j ->
  229. let called =
  230. match names.(j) with
  231. Name id -> pr_id id
  232. | Anonymous -> str "the " ++ nth i ++ str " definition" in
  233. str "Recursive call to " ++ called ++ str " has not enough arguments"
  234. (* CoFixpoint guard errors *)
  235. | CodomainNotInductiveType c ->
  236. str "The codomain is" ++ spc () ++ pr_lconstr_env env c ++ spc () ++
  237. str "which should be a coinductive type"
  238. | NestedRecursiveOccurrences ->
  239. str "Nested recursive occurrences"
  240. | UnguardedRecursiveCall c ->
  241. str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env c
  242. | RecCallInTypeOfAbstraction c ->
  243. str "Recursive call forbidden in the domain of an abstraction:" ++
  244. spc () ++ pr_lconstr_env env c
  245. | RecCallInNonRecArgOfConstructor c ->
  246. str "Recursive call on a non-recursive argument of constructor" ++
  247. spc () ++ pr_lconstr_env env c
  248. | RecCallInTypeOfDef c ->
  249. str "Recursive call forbidden in the type of a recursive definition" ++
  250. spc () ++ pr_lconstr_env env c
  251. | RecCallInCaseFun c ->
  252. str "Recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c
  253. | RecCallInCaseArg c ->
  254. str "Recursive call in the argument of cases in" ++ spc () ++
  255. pr_lconstr_env env c
  256. | RecCallInCasePred c ->
  257. str "Recursive call in the type of cases in" ++ spc () ++
  258. pr_lconstr_env env c
  259. | NotGuardedForm c ->
  260. str "Sub-expression " ++ pr_lconstr_env env c ++
  261. strbrk " not in guarded form (should be a constructor," ++
  262. strbrk " an abstraction, a match, a cofix or a recursive call)"
  263. in
  264. prt_name i ++ str " is ill-formed." ++ fnl () ++
  265. pr_ne_context_of (str "In environment") env ++
  266. st ++ str "."
  267. let explain_ill_typed_rec_body env i names vdefj vargs =
  268. let env = make_all_name_different env in
  269. let pvd,pvdt = pr_ljudge_env env (vdefj.(i)) in
  270. let pv = pr_lconstr_env env vargs.(i) in
  271. str "The " ++
  272. (if Array.length vdefj = 1 then mt () else nth (i+1) ++ spc ()) ++
  273. str "recursive definition" ++ spc () ++ pvd ++ spc () ++
  274. str "has type" ++ spc () ++ pvdt ++ spc () ++
  275. str "while it should be" ++ spc () ++ pv ++ str "."
  276. let explain_cant_find_case_type env c =
  277. let env = make_all_name_different env in
  278. let pe = pr_lconstr_env env c in
  279. str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "."
  280. let explain_occur_check env ev rhs =
  281. let env = make_all_name_different env in
  282. let id = Evd.string_of_existential ev in
  283. let pt = pr_lconstr_env env rhs in
  284. str "Cannot define " ++ str id ++ str " with term" ++ brk(1,1) ++
  285. pt ++ spc () ++ str "that would depend on itself."
  286. let pr_ne_context_of header footer env =
  287. if Environ.rel_context env = empty_rel_context &
  288. Environ.named_context env = empty_named_context
  289. then footer
  290. else pr_ne_context_of header env
  291. let explain_hole_kind env evi = function
  292. | QuestionMark _ -> str "this placeholder"
  293. | CasesType ->
  294. str "the type of this pattern-matching problem"
  295. | BinderType (Name id) ->
  296. str "the type of " ++ Nameops.pr_id id
  297. | BinderType Anonymous ->
  298. str "the type of this anonymous binder"
  299. | ImplicitArg (c,(n,ido)) ->
  300. let id = Option.get ido in
  301. str "the implicit parameter " ++
  302. pr_id id ++ spc () ++ str "of" ++
  303. spc () ++ Nametab.pr_global_env Idset.empty c
  304. | InternalHole ->
  305. str "an internal placeholder" ++
  306. Option.cata (fun evi ->
  307. let env = Evd.evar_env evi in
  308. str " of type " ++ pr_lconstr_env env evi.evar_concl ++
  309. pr_ne_context_of (str " in environment:"++ fnl ()) (mt ()) env)
  310. (mt ()) evi
  311. | TomatchTypeParameter (tyi,n) ->
  312. str "the " ++ nth n ++
  313. str " argument of the inductive type (" ++ pr_inductive env tyi ++
  314. str ") of this term"
  315. | GoalEvar ->
  316. str "an existential variable"
  317. | ImpossibleCase ->
  318. str "the type of an impossible pattern-matching clause"
  319. let explain_not_clean env ev t k =
  320. let env = make_all_name_different env in
  321. let id = Evd.string_of_existential ev in
  322. let var = pr_lconstr_env env t in
  323. str "Tried to instantiate " ++ explain_hole_kind env None k ++
  324. str " (" ++ str id ++ str ")" ++ spc () ++
  325. str "with a term using variable " ++ var ++ spc () ++
  326. str "which is not in its scope."
  327. let explain_unsolvability = function
  328. | None -> mt()
  329. | Some (SeveralInstancesFound n) ->
  330. strbrk " (several distinct possible instances found)"
  331. let explain_typeclass_resolution env evi k =
  332. match k with
  333. | GoalEvar | InternalHole | ImplicitArg _ ->
  334. (match Typeclasses.class_of_constr evi.evar_concl with
  335. | Some c ->
  336. let env = Evd.evar_env evi in
  337. fnl () ++ str "Could not find an instance for " ++
  338. pr_lconstr_env env evi.evar_concl ++
  339. pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env
  340. | None -> mt())
  341. | _ -> mt()
  342. let explain_unsolvable_implicit env evi k explain =
  343. str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++
  344. explain_unsolvability explain ++ str "." ++
  345. explain_typeclass_resolution env evi k
  346. let explain_var_not_found env id =
  347. str "The variable" ++ spc () ++ pr_id id ++
  348. spc () ++ str "was not found" ++
  349. spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "."
  350. let explain_wrong_case_info env ind ci =
  351. let pi = pr_inductive (Global.env()) ind in
  352. if ci.ci_ind = ind then
  353. str "Pattern-matching expression on an object of inductive type" ++
  354. spc () ++ pi ++ spc () ++ str "has invalid information."
  355. else
  356. let pc = pr_inductive (Global.env()) ci.ci_ind in
  357. str "A term of inductive type" ++ spc () ++ pi ++ spc () ++
  358. str "was given to a pattern-matching expression on the inductive type" ++
  359. spc () ++ pc ++ str "."
  360. let explain_cannot_unify env m n =
  361. let pm = pr_lconstr_env env m in
  362. let pn = pr_lconstr_env env n in
  363. str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++
  364. str "with" ++ brk(1,1) ++ pn ++ str "."
  365. let explain_cannot_unify_local env m n subn =
  366. let pm = pr_lconstr_env env m in
  367. let pn = pr_lconstr_env env n in
  368. let psubn = pr_lconstr_env env subn in
  369. str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++
  370. str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++
  371. psubn ++ str " contains local variables."
  372. let explain_refiner_cannot_generalize env ty =
  373. str "Cannot find a well-typed generalisation of the goal with type: " ++
  374. pr_lconstr_env env ty ++ str "."
  375. let explain_no_occurrence_found env c id =
  376. str "Found no subterm matching " ++ pr_lconstr_env env c ++
  377. str " in " ++
  378. (match id with
  379. | Some id -> pr_id id
  380. | None -> str"the current goal") ++ str "."
  381. let explain_cannot_unify_binding_type env m n =
  382. let pm = pr_lconstr_env env m in
  383. let pn = pr_lconstr_env env n in
  384. str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++
  385. str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "."
  386. let explain_cannot_find_well_typed_abstraction env p l =
  387. str "Abstracting over the " ++
  388. str (plural (List.length l) "term") ++ spc () ++
  389. hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++
  390. str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++
  391. str "which is ill-typed."
  392. let explain_type_error env err =
  393. let env = make_all_name_different env in
  394. match err with
  395. | UnboundRel n ->
  396. explain_unbound_rel env n
  397. | UnboundVar v ->
  398. explain_unbound_var env v
  399. | NotAType j ->
  400. explain_not_type env j
  401. | BadAssumption c ->
  402. explain_bad_assumption env c
  403. | ReferenceVariables id ->
  404. explain_reference_variables id
  405. | ElimArity (ind, aritylst, c, pj, okinds) ->
  406. explain_elim_arity env ind aritylst c pj okinds
  407. | CaseNotInductive cj ->
  408. explain_case_not_inductive env cj
  409. | NumberBranches (cj, n) ->
  410. explain_number_branches env cj n
  411. | IllFormedBranch (c, i, actty, expty) ->
  412. explain_ill_formed_branch env c i actty expty
  413. | Generalization (nvar, c) ->
  414. explain_generalization env nvar c
  415. | ActualType (j, pt) ->
  416. explain_actual_type env j pt
  417. | CantApplyBadType (t, rator, randl) ->
  418. explain_cant_apply_bad_type env t rator randl
  419. | CantApplyNonFunctional (rator, randl) ->
  420. explain_cant_apply_not_functional env rator randl
  421. | IllFormedRecBody (err, lna, i, fixenv, vdefj) ->
  422. explain_ill_formed_rec_body env err lna i fixenv vdefj
  423. | IllTypedRecBody (i, lna, vdefj, vargs) ->
  424. explain_ill_typed_rec_body env i lna vdefj vargs
  425. | WrongCaseInfo (ind,ci) ->
  426. explain_wrong_case_info env ind ci
  427. let explain_pretype_error env err =
  428. let env = make_all_name_different env in
  429. match err with
  430. | CantFindCaseType c -> explain_cant_find_case_type env c
  431. | OccurCheck (n,c) -> explain_occur_check env n c
  432. | NotClean (n,c,k) -> explain_not_clean env n c k
  433. | UnsolvableImplicit (evi,k,exp) -> explain_unsolvable_implicit env evi k exp
  434. | VarNotFound id -> explain_var_not_found env id
  435. | UnexpectedType (actual,expect) -> explain_unexpected_type env actual expect
  436. | NotProduct c -> explain_not_product env c
  437. | CannotUnify (m,n) -> explain_cannot_unify env m n
  438. | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env m n sn
  439. | CannotGeneralize ty -> explain_refiner_cannot_generalize env ty
  440. | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env c id
  441. | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n
  442. | CannotFindWellTypedAbstraction (p,l) ->
  443. explain_cannot_find_well_typed_abstraction env p l
  444. (* Typeclass errors *)
  445. let explain_not_a_class env c =
  446. pr_constr_env env c ++ str" is not a declared type class."
  447. let explain_unbound_method env cid id =
  448. str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++
  449. pr_global cid ++ str "."
  450. let pr_constr_exprs exprs =
  451. hv 0 (List.fold_right
  452. (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps)
  453. exprs (mt ()))
  454. let explain_no_instance env (_,id) l =
  455. str "No instance found for class " ++ Nameops.pr_id id ++ spc () ++
  456. str "applied to arguments" ++ spc () ++
  457. prlist_with_sep pr_spc (pr_lconstr_env env) l
  458. let pr_constraints printenv env evm =
  459. let l = Evd.to_list evm in
  460. let (ev, evi) = List.hd l in
  461. if List.for_all (fun (ev', evi') ->
  462. eq_named_context_val evi.evar_hyps evi'.evar_hyps) l
  463. then
  464. let pe = pr_ne_context_of (str "In environment:") (mt ())
  465. (reset_with_named_context evi.evar_hyps env) in
  466. (if printenv then pe ++ fnl () else mt ()) ++
  467. prlist_with_sep (fun () -> fnl ())
  468. (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l
  469. else
  470. pr_evar_map evm
  471. let explain_unsatisfiable_constraints env evd constr =
  472. let evm = Evd.evars_of evd in
  473. match constr with
  474. | None ->
  475. str"Unable to satisfy the following constraints:" ++ fnl() ++
  476. pr_constraints true env evm
  477. | Some (evi, k) ->
  478. explain_unsolvable_implicit env evi k None ++ fnl () ++
  479. if List.length (Evd.to_list evm) > 1 then
  480. str"With the following constraints:" ++ fnl() ++
  481. pr_constraints false env evm
  482. else mt ()
  483. let explain_mismatched_contexts env c i j =
  484. str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++
  485. hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++
  486. hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i)
  487. let explain_typeclass_error env err =
  488. match err with
  489. | NotAClass c -> explain_not_a_class env c
  490. | UnboundMethod (cid, id) -> explain_unbound_method env cid id
  491. | NoInstance (id, l) -> explain_no_instance env id l
  492. | UnsatisfiableConstraints (evd, c) -> explain_unsatisfiable_constraints env evd c
  493. | MismatchedContextInstance (c, i, j) -> explain_mismatched_contexts env c i j
  494. (* Refiner errors *)
  495. let explain_refiner_bad_type arg ty conclty =
  496. str "Refiner was given an argument" ++ brk(1,1) ++
  497. pr_lconstr arg ++ spc () ++
  498. str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++
  499. str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "."
  500. let explain_refiner_unresolved_bindings l =
  501. str "Unable to find an instance for the " ++
  502. str (plural (List.length l) "variable") ++ spc () ++
  503. prlist_with_sep pr_coma pr_name l ++ str"."
  504. let explain_refiner_cannot_apply t harg =
  505. str "In refiner, a term of type" ++ brk(1,1) ++
  506. pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++
  507. pr_lconstr harg ++ str "."
  508. let explain_refiner_not_well_typed c =
  509. str "The term " ++ pr_lconstr c ++ str " is not well-typed."
  510. let explain_intro_needs_product () =
  511. str "Introduction tactics needs products."
  512. let explain_does_not_occur_in c hyp =
  513. str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++
  514. str "does not occur in" ++ spc () ++ pr_id hyp ++ str "."
  515. let explain_non_linear_proof c =
  516. str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++
  517. spc () ++ str "because a metavariable has several occurrences."
  518. let explain_meta_in_type c =
  519. str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++
  520. str " of another meta"
  521. let explain_refiner_error = function
  522. | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
  523. | UnresolvedBindings t -> explain_refiner_unresolved_bindings t
  524. | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg
  525. | NotWellTyped c -> explain_refiner_not_well_typed c
  526. | IntroNeedsProduct -> explain_intro_needs_product ()
  527. | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp
  528. | NonLinearProof c -> explain_non_linear_proof c
  529. | MetaInType c -> explain_meta_in_type c
  530. (* Inductive errors *)
  531. let error_non_strictly_positive env c v =
  532. let pc = pr_lconstr_env env c in
  533. let pv = pr_lconstr_env env v in
  534. str "Non strictly positive occurrence of " ++ pv ++ str " in" ++
  535. brk(1,1) ++ pc ++ str "."
  536. let error_ill_formed_inductive env c v =
  537. let pc = pr_lconstr_env env c in
  538. let pv = pr_lconstr_env env v in
  539. str "Not enough arguments applied to the " ++ pv ++
  540. str " in" ++ brk(1,1) ++ pc ++ str "."
  541. let error_ill_formed_constructor env id c v nparams nargs =
  542. let pv = pr_lconstr_env env v in
  543. let atomic = (nb_prod c = 0) in
  544. str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++
  545. str "is not valid;" ++ brk(1,1) ++
  546. strbrk (if atomic then "it must be " else "its conclusion must be ") ++
  547. pv ++
  548. (* warning: because of implicit arguments it is difficult to say which
  549. parameters must be explicitly given *)
  550. (if nparams<>0 then
  551. strbrk " applied to its " ++ str (plural nparams "parameter")
  552. else
  553. mt()) ++
  554. (if nargs<>0 then
  555. str (if nparams<>0 then " and" else " applied") ++
  556. strbrk " to some " ++ str (plural nargs "argument")
  557. else
  558. mt()) ++ str "."
  559. let error_bad_ind_parameters env c n v1 v2 =
  560. let pc = pr_lconstr_env_at_top env c in
  561. let pv1 = pr_lconstr_env env v1 in
  562. let pv2 = pr_lconstr_env env v2 in
  563. str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++
  564. str " as " ++ nth n ++ str " argument in " ++ brk(1,1) ++ pc ++ str "."
  565. let error_same_names_types id =
  566. str "The name" ++ spc () ++ pr_id id ++ spc () ++
  567. str "is used more than once."
  568. let error_same_names_constructors id =
  569. str "The constructor name" ++ spc () ++ pr_id id ++ spc () ++
  570. str "is used more than once."
  571. let error_same_names_overlap idl =
  572. strbrk "The following names are used both as type names and constructor " ++
  573. str "names:" ++ spc () ++
  574. prlist_with_sep pr_coma pr_id idl ++ str "."
  575. let error_not_an_arity id =
  576. str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity."
  577. let error_bad_entry () =
  578. str "Bad inductive definition."
  579. let error_large_non_prop_inductive_not_in_type () =
  580. str "Large non-propositional inductive types must be in Type."
  581. (* Recursion schemes errors *)
  582. let error_not_allowed_case_analysis isrec kind i =
  583. str (if isrec then "Induction" else "Case analysis") ++
  584. strbrk " on sort " ++ pr_sort kind ++
  585. strbrk " is not allowed for inductive definition " ++
  586. pr_inductive (Global.env()) i ++ str "."
  587. let error_not_mutual_in_scheme ind ind' =
  588. if ind = ind' then
  589. str "The inductive type " ++ pr_inductive (Global.env()) ind ++
  590. str "occurs twice."
  591. else
  592. str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++
  593. str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++
  594. str "are not mutually defined."
  595. (* Inductive constructions errors *)
  596. let explain_inductive_error = function
  597. | NonPos (env,c,v) -> error_non_strictly_positive env c v
  598. | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v
  599. | NotConstructor (env,id,c,v,n,m) ->
  600. error_ill_formed_constructor env id c v n m
  601. | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2
  602. | SameNamesTypes id -> error_same_names_types id
  603. | SameNamesConstructors id -> error_same_names_constructors id
  604. | SameNamesOverlap idl -> error_same_names_overlap idl
  605. | NotAnArity id -> error_not_an_arity id
  606. | BadEntry -> error_bad_entry ()
  607. | LargeNonPropInductiveNotInType -> error_large_non_prop_inductive_not_in_type ()
  608. (* Recursion schemes errors *)
  609. let explain_recursion_scheme_error = function
  610. | NotAllowedCaseAnalysis (isrec,k,i) ->
  611. error_not_allowed_case_analysis isrec k i
  612. | NotMutualInScheme (ind,ind')-> error_not_mutual_in_scheme ind ind'
  613. (* Pattern-matching errors *)
  614. let explain_bad_pattern env cstr ty =
  615. let env = make_all_name_different env in
  616. let pt = pr_lconstr_env env ty in
  617. let pc = pr_constructor env cstr in
  618. str "Found the constructor " ++ pc ++ brk(1,1) ++
  619. str "while matching a term of type " ++ pt ++ brk(1,1) ++
  620. str "which is not an inductive type."
  621. let explain_bad_constructor env cstr ind =
  622. let pi = pr_inductive env ind in
  623. (* let pc = pr_constructor env cstr in*)
  624. let pt = pr_inductive env (inductive_of_constructor cstr) in
  625. str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++
  626. str "while a constructor of " ++ pi ++ brk(1,1) ++
  627. str "is expected."
  628. let decline_string n s =
  629. if n = 0 then "no "^s^"s"
  630. else if n = 1 then "1 "^s
  631. else (string_of_int n^" "^s^"s")
  632. let explain_wrong_numarg_constructor env cstr n =
  633. str "The constructor " ++ pr_constructor env cstr ++
  634. str " expects " ++ str (decline_string n "argument") ++ str "."
  635. let explain_wrong_numarg_inductive env ind n =
  636. str "The inductive type " ++ pr_inductive env ind ++
  637. str " expects " ++ str (decline_string n "argument") ++ str "."
  638. let explain_wrong_predicate_arity env pred nondep_arity dep_arity=
  639. let env = make_all_name_different env in
  640. let pp = pr_lconstr_env env pred in
  641. str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++
  642. str "should be of arity" ++ spc () ++
  643. pr_lconstr_env env nondep_arity ++ spc () ++
  644. str "(for non dependent case) or" ++
  645. spc () ++ pr_lconstr_env env dep_arity ++ spc () ++ str "(for dependent case)."
  646. let explain_needs_inversion env x t =
  647. let env = make_all_name_different env in
  648. let px = pr_lconstr_env env x in
  649. let pt = pr_lconstr_env env t in
  650. str "Sorry, I need inversion to compile pattern matching on term " ++
  651. px ++ str " of type: " ++ pt ++ str "."
  652. let explain_unused_clause env pats =
  653. (* Without localisation
  654. let s = if List.length pats > 1 then "s" else "" in
  655. (str ("Unused clause with pattern"^s) ++ spc () ++
  656. hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")")
  657. *)
  658. str "This clause is redundant."
  659. let explain_non_exhaustive env pats =
  660. str "Non exhaustive pattern-matching: no clause found for " ++
  661. str (plural (List.length pats) "pattern") ++
  662. spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats)
  663. let explain_cannot_infer_predicate env typs =
  664. let env = make_all_name_different env in
  665. let pr_branch (cstr,typ) =
  666. let cstr,_ = decompose_app cstr in
  667. str "For " ++ pr_lconstr_env env cstr ++ str ": " ++ pr_lconstr_env env typ
  668. in
  669. str "Unable to unify the types found in the branches:" ++
  670. spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs))
  671. let explain_pattern_matching_error env = function
  672. | BadPattern (c,t) ->
  673. explain_bad_pattern env c t
  674. | BadConstructor (c,ind) ->
  675. explain_bad_constructor env c ind
  676. | WrongNumargConstructor (c,n) ->
  677. explain_wrong_numarg_constructor env c n
  678. | WrongNumargInductive (c,n) ->
  679. explain_wrong_numarg_inductive env c n
  680. | WrongPredicateArity (pred,n,dep) ->
  681. explain_wrong_predicate_arity env pred n dep
  682. | NeedsInversion (x,t) ->
  683. explain_needs_inversion env x t
  684. | UnusedClause tms ->
  685. explain_unused_clause env tms
  686. | NonExhaustive tms ->
  687. explain_non_exhaustive env tms
  688. | CannotInferPredicate typs ->
  689. explain_cannot_infer_predicate env typs
  690. let explain_reduction_tactic_error = function
  691. | Tacred.InvalidAbstraction (env,c,(env',e)) ->
  692. str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++
  693. spc () ++ str "is not well typed." ++ fnl () ++
  694. explain_type_error env' e
  695. let explain_ltac_call_trace (last,trace,loc) =
  696. let calls = last :: List.rev (List.map snd trace) in
  697. let pr_call = function
  698. | Proof_type.LtacNotationCall s -> quote (str s)
  699. | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
  700. | Proof_type.LtacVarCall (id,t) ->
  701. quote (Nameops.pr_id id) ++ strbrk " (bound to " ++
  702. Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
  703. | Proof_type.LtacAtomCall (te,otac) -> quote
  704. (Pptactic.pr_glob_tactic (Global.env())
  705. (Tacexpr.TacAtom (dummy_loc,te)))
  706. ++ (match !otac with
  707. | Some te' when (Obj.magic te' <> te) ->
  708. strbrk " (expanded to " ++ quote
  709. (Pptactic.pr_tactic (Global.env())
  710. (Tacexpr.TacAtom (dummy_loc,te')))
  711. ++ str ")"
  712. | _ -> mt ())
  713. | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) ->
  714. let filter =
  715. function (id,None) -> None | (id,Some id') -> Some(id,mkVar id') in
  716. let unboundvars = list_map_filter filter unboundvars in
  717. quote (pr_rawconstr_env (Global.env()) c) ++
  718. (if unboundvars <> [] or vars <> [] then
  719. strbrk " (with " ++ prlist_with_sep pr_coma (fun (id,c) ->
  720. pr_id id ++ str ":=" ++ Printer.pr_lconstr c)
  721. (List.rev vars @ unboundvars) ++ str ")"
  722. else mt()) in
  723. if calls <> [] then
  724. let kind_of_last_call = match list_last calls with
  725. | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed."
  726. | _ -> ", last call failed." in
  727. hov 0 (str "In nested Ltac calls to " ++
  728. pr_enum pr_call calls ++ strbrk kind_of_last_call)
  729. else
  730. mt ()