2 % (c) The AQUA Project, Glasgow University, 1994-1995
4 \section[ErrsTc]{Reporting errors from the typechecker}
6 This is an internal module---access to these functions is through
9 DPH errors are in here, too.
12 #include "HsVersions.h"
15 UnifyErrContext(..), UnifyErrInfo(..),
26 derivingWhenInstanceExistsErr,
31 methodTypeLacksTyVarErr,
32 naughtyCCallContextErr,
39 specCtxtGroundnessErr,
43 specInstUnspecInstNotFoundErr,
44 topLevelUnboxedDeclErr,
52 import AbsSyn -- we print a bunch of stuff in here
53 import UniType ( UniType(..) ) -- Concrete, to make some errors
56 import AbsUniType ( extractTyVarsFromTy, pprMaybeTy,
57 TyVar, TyVarTemplate, TyCon,
58 TauType(..), Class, ClassOp
59 IF_ATTACK_PRAGMAS(COMMA pprUniType)
61 import Bag ( Bag, bagToList )
62 import GenSpecEtc ( SignatureInfo(..) )
63 import HsMatches ( pprMatches, pprMatch, pprGRHS )
64 import Id ( getIdUniType, Id, isSysLocalId )
65 import Inst ( getInstOrigin, getDictClassAndType, Inst )
66 import Name ( cmpName )
68 import Pretty -- to pretty-print error messages
70 import PodizeMonad ( PodWarning(..) )
71 #endif {- Data Parallel Haskell -}
72 import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
77 ambigErr :: [Inst] -> Error
78 ambigErr insts@(inst1:_)
79 = addErrLoc loc1 "Ambiguous overloading" ( \ sty ->
80 ppAboves (map (ppr_inst sty) insts) )
82 (loc1, _) = getInstOrigin inst1
86 (clas, ty) = getDictClassAndType inst
87 (locn, msg) = getInstOrigin inst
89 ppSep [ ppBesides [ppStr "class `", ppr sty clas,
90 ppStr "', type `", ppr sty ty, ppStr "'"],
91 ppBesides [ppStr "(", msg sty, ppStr ")"] ]
93 ----------------------------------------------------------------
94 badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> Error
95 badMatchErr sig_ty inferred_ty ctxt locn
96 = addErrLoc locn "Type signature mismatch" ( \ sty ->
100 SigCtxt id _ -> ppBesides [ppChar '`', ppr sty id, ppChar '\'']
101 MethodSigCtxt op _ -> ppBesides [ppStr "class method `", ppr sty op, ppStr "'"]
102 ExprSigCtxt _ _ -> ppStr "an expression"
103 Rank2ArgCtxt _ _ -> ppStr "an expression with rank-2 polymorphic type(!)"
104 ctxt -> pprUnifyErrContext sty ctxt
105 -- the latter is ugly, but better than a patt-match failure
108 ppStr "Signature for", thing, ppStr "doesn't match its inferred type."
110 ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
111 ppHang (ppStr "Inferred type:") 4 (ppr sty inferred_ty)
114 ----------------------------------------------------------------
115 badSpecialisationErr :: String -> String -> Int -> [Maybe UniType] -> SrcLoc -> Error
117 badSpecialisationErr flavor messg no_tyvars ty_maybes locn
118 = addErrLoc locn ("Bad "++flavor++" specialisation pragma: "++messg) ( \ sty ->
119 ppStr "MSG NOT DONE YET"
122 ----------------------------------------------------------------
123 confusedNameErr :: String
124 -> Name -- the confused name
127 confusedNameErr msg nm locn
128 = addErrLoc locn msg ( \ sty ->
132 msg = if flag then "Type constructor used where a class is expected"
133 else "Class used where a type constructor is expected"
136 ----------------------------------------------------------------
137 typeCycleErr :: [[(Pretty, SrcLoc)]] -> Error
138 typeCycleErr = cycleErr "The following type synonyms refer to themselves:"
140 classCycleErr :: [[(Pretty, SrcLoc)]] -> Error
141 classCycleErr = cycleErr "The following classes form a cycle:"
143 cycleErr :: String -> [[(Pretty, SrcLoc)]] -> Error
144 cycleErr msg cycles sty
146 4 (ppAboves (map pp_cycle cycles))
148 pp_cycle things = ppAboves (map pp_thing things)
149 pp_thing (thing,loc) = ppHang (ppBesides [ppr PprForUser loc, ppStr ": "]) 4 thing
151 ----------------------------------------------------------------
152 defaultErr :: [Inst]{-dicts-} -> [UniType] -> Error
153 -- when default-resolution fails...
155 defaultErr dicts defaulting_tys sty
156 = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
158 ppHang (ppStr "Conflicting:")
159 4 (ppInterleave ppSemi (map (ppr_inst sty) dicts)),
160 ppHang (ppStr "Defaulting types :")
161 4 (ppr sty defaulting_tys),
162 ppStr "([Int, Double] is the default list of defaulting types.)" ])
164 ----------------------------------------------------------------
165 derivingEnumErr :: TyCon -> Error
166 derivingEnumErr tycon
167 = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
168 ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
170 ----------------------------------------------------------------
171 derivingIxErr :: TyCon -> Error
173 = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
174 ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
176 ----------------------------------------------------------------
177 derivingWhenInstanceExistsErr :: Class -> TyCon -> Error
178 derivingWhenInstanceExistsErr clas tycon
179 = addErrLoc (getSrcLoc tycon) "`deriving' when an instance also exists" ( \ sty ->
180 ppBesides [ppStr "class `", ppr sty clas,
181 ppStr "', type `", ppr sty tycon, ppStr "'"] )
183 ----------------------------------------------------------------
185 derivingNoSuperClassInstanceErr :: Class -> TyCon -> Class -> Error
186 derivingNoSuperClassInstanceErr clas tycon super_class
187 = addErrLoc (getSrcLoc tycon) "No instance for a superclass in a `deriving'" ( \ sty ->
188 ppSep [ppBesides [ppStr "the superclass `", ppr sty super_class, ppStr "' has no instance"],
189 ppBesides [ppStr "at the type `", ppr sty tycon, ppStr "';"],
190 ppBesides [ppStr "(the class being \"derived\" is `", ppr sty clas, ppStr "')"]
194 ----------------------------------------------------------------
195 dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
196 dupInstErr (clas, info1@(ty1, locn1), info2@(ty2, locn2))
197 -- Overlapping/duplicate instances for given class; msg could be more glamourous
198 = addErrLoc locn1 "Duplicate/overlapping instances" ( \ sty ->
199 ppSep [ ppBesides [ppStr "class `", ppr sty clas, ppStr "',"],
200 showOverlap sty info1 info2] )
202 ----------------------------------------------------------------
204 extraMethodsErr :: [Id] {-dicts-} -> SrcLoc -> Error
205 -- when an instance decl has binds for methods that aren't in the class decl
206 extraMethodsErr extra_methods locn
207 = addErrLoc locn "Extra methods in instance declaration" ( \ sty ->
208 interpp'SP sty extra_methods )
211 ----------------------------------------------------------------
212 genCantGenErr :: [Inst] -> Error
213 genCantGenErr insts@(inst1:_)
214 = addErrLoc loc1 "Cannot generalise these overloadings (in a _ccall_):" ( \ sty ->
215 ppAboves (map (ppr_inst sty) insts) )
217 (loc1, _) = getInstOrigin inst1
219 ----------------------------------------------------------------
221 genPrimTyVarErr :: [TyVar] -> SrcLoc -> Error
222 -- Attempt to generalise over a primitive type variable
224 genPrimTyVarErr tyvars locn
225 = addErrLoc locn "These primitive type variables can't be made more general" ( \ sty ->
226 ppAbove (interpp'SP sty tyvars)
227 (ppStr "(Solution: add a type signature.)") )
229 ----------------------------------------------------------------
230 noInstanceErr :: Inst -> Error
232 = let (clas, ty) = getDictClassAndType inst
233 (locn, msg) = getInstOrigin inst
235 addErrLoc locn "No such instance" ( \ sty ->
236 ppSep [ ppBesides [ppStr "class `", ppr sty clas,
237 ppStr "', type `", ppr sty ty, ppStr "'"],
238 ppBesides [ppStr "(", msg sty, ppStr ")"] ]
241 ----------------------------------------------------------------
243 instOpErr :: Id -> Class -> TyCon -> Error
245 instOpErr dict clas tycon
246 -- no instance of "Class" for "TyCon"
247 -- the Id is the offending dictionary; has src location
248 -- (and we could get the Class and TyCon from it, but
249 -- since we already have it at hand ...)
250 = addErrLoc (getSrcLoc dict) "Invalid instance" ( \ sty ->
251 ppBesides [ ppStr "There is no instance of `", ppr sty tycon,
252 ppStr "' for class `",
253 ppr sty clas, ppChar '\'' ] )
256 ----------------------------------------------------------------
257 instTypeErr :: UniType -> SrcLoc -> Error
259 = addShortErrLocLine locn (\ sty ->
261 rest_of_msg = ppStr "' cannot be used as the instance type\n in an instance declaration."
264 UniSyn tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
265 UniTyVar tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
266 other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
269 ----------------------------------------------------------------
270 lurkingRank2Err :: Name -> UniType -> SrcLoc -> Error
271 lurkingRank2Err name ty locn
272 = addErrLoc locn "Illegal use of a non-Hindley-Milner variable" ( \ sty ->
274 ppBesides [ppStr "The variable is `", ppr sty name, ppStr "'."],
275 ppStr "Its type does not have all its for-alls at the top",
276 ppBesides [ppStr "(the type is `", ppr sty ty, ppStr "'),"],
277 ppStr "nor is it a full application of a rank-2-typed variable.",
278 ppStr "(Most common cause: `_runST' or `_build' not applied to an argument.)"])
280 ----------------------------------------------------------------
282 methodInstErr :: (ClassOp, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
283 methodInstErr (class_op, info1, info2) sty
284 -- Two instances for given class op
285 = ppHang (ppBesides [ ppStr "The class method `", ppr sty class_op, ppStr "' has been given more than one definition for"])
286 4 (showOverlap sty info1 info2)
289 showOverlap :: PprStyle -> (UniType, SrcLoc) -> (UniType, SrcLoc) -> Pretty
290 showOverlap sty (ty1,loc1) (ty2,loc2)
291 = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
292 ppBeside (ppStr "at ") (ppr sty loc1),
293 ppBeside (ppStr "and ") (ppr sty loc2)]
295 ----------------------------------------------------------------
296 methodTypeLacksTyVarErr :: TyVarTemplate -> String -> SrcLoc -> Error
297 methodTypeLacksTyVarErr tyvar method_name locn
298 = addErrLoc locn "Method's type doesn't mention the class type variable" (\ sty ->
299 ppAboves [ppBeside (ppStr "Class type variable: ") (ppr sty tyvar),
300 ppBeside (ppStr "Method: ") (ppStr method_name)] )
302 ----------------------------------------------------------------
304 missingClassOpErr :: Id -> [ClassOp] -> SrcLoc -> Error
305 missingClassOpErr op classops locn
306 = addErrLoc locn "Undefined class method" ( \ sty ->
307 ppBesides [ ppr sty op, ppStr "; valid method(s):",
308 interpp'SP sty classops ] )
311 ----------------------------------------------------------------
312 naughtyCCallContextErr :: Name -> SrcLoc -> Error
313 naughtyCCallContextErr clas_name locn
314 = addErrLoc locn "Can't use this class in a context" (\ sty ->
317 ----------------------------------------------------------------
318 nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> Error
319 nonBoxedPrimCCallErr clas inst_ty locn
320 = addErrLoc locn "Instance isn't for a `boxed-primitive' type" ( \ sty ->
321 ppBesides [ ppStr "class `", ppr sty clas, ppStr "'; type `",
322 ppr sty inst_ty, ppStr "'"] )
324 ----------------------------------------------------------------
325 notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> Error
326 notAsPolyAsSigErr sig_ty mono_tyvars ctxt locn
327 = addErrLoc locn "A type signature is more polymorphic than the inferred type" ( \ sty ->
328 ppAboves [ ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
329 pprUnifyErrContext sty ctxt,
330 ppHang (ppStr "Monomorphic type variable(s):")
331 4 (interpp'SP sty mono_tyvars),
332 ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
335 ----------------------------------------------------------------
337 patMatchWithPrimErr :: Error
340 "Pattern-bindings may not involve primitive types." ( \ sty ->
344 ----------------------------------------------------------------
345 preludeInstanceErr :: Class -> UniType -> SrcLoc -> Error
346 preludeInstanceErr clas ty locn
347 = addShortErrLocLine locn ( \ sty ->
348 ppHang (ppBesides [ppStr "Illegal instance: for Prelude class `", ppr sty clas,
349 ppStr "' and Prelude type `", ppr sty ty, ppStr "'."] )
350 4 (ppStr "(An instance decl must be in the same module as the type decl or the class decl)") )
352 ----------------------------------------------------------------
354 purelyLocalErr :: Name -> SrcLoc -> Error
355 purelyLocalErr thing locn
356 = addShortErrLocLine locn ( \ sty ->
357 ppBesides [ppStr "`", ppr sty thing,
358 ppStr "' cannot be exported -- it would refer to an unexported local entity."] )
361 ----------------------------------------------------------------
362 reduceErr :: [Inst] -> UnifyErrContext -> Error
363 -- Used by tcSimplifyCheckLIE
364 -- Could not express required dictionaries in terms of the signature
366 = dontAddErrLoc "Type signature lacks context required by inferred type" ( \ sty ->
368 pprUnifyErrContext sty ctxt,
369 ppHang (ppStr "Context reqd: ")
370 4 (ppAboves (map (ppr_inst sty) insts))
374 = let (clas, ty) = getDictClassAndType inst
375 (locn, msg) = getInstOrigin inst
377 ppSep [ ppBesides [ppr sty locn, ppStr ": ", ppr sty clas, ppSP, ppr sty ty],
378 ppBesides [ppStr "(", msg sty, ppStr ")"] ]
380 ----------------------------------------------------------------
382 unexpectedPreludeThingErr :: Outputable a => String -> a -> SrcLoc -> Error
384 unexpectedPreludeThingErr category thing locn
385 = addShortErrLocLine locn ( \ sty ->
386 ppBesides [ppStr "Prelude ", ppStr category,
387 ppStr " not expected here: ", ppr sty thing])
390 ----------------------------------------------------------------
391 specGroundnessErr :: UnifyErrContext -> [UniType] -> Error
393 specGroundnessErr (ValSpecSigCtxt name spec_ty locn) arg_tys
394 = addShortErrLocLine locn ( \ sty ->
396 ppSep [ppStr "In the SPECIALIZE pragma for `", ppr sty name,
397 ppStr "'... not all type variables were specialised",
398 ppStr "to type variables or ground types (nothing in between, please!):"])
399 4 (ppAboves (map (ppr sty) arg_tys))
402 specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys
403 = addShortErrLocLine locn ( \ sty ->
405 ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
406 ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"],
407 ppStr "... not all type variables were instantiated",
408 ppStr "to type variables or ground types (nothing in between, please!):"])
409 4 (ppAboves (map (ppr sty) arg_tys))
412 ----------------------------------------------------------------
413 specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> Error
415 specCtxtGroundnessErr err_ctxt dicts
416 = addShortErrLocLine locn ( \ sty ->
418 ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
419 ppBesides [ppStr " specialised to the type `", ppr sty spec_ty, ppStr "'"],
421 ppStr "... not all overloaded type variables were instantiated",
422 ppStr "to ground types:"])
423 4 (ppAboves [ppCat [ppr sty c, ppr sty t]
424 | (c,t) <- map getDictClassAndType dicts])
427 (name, spec_ty, locn, pp_spec_id)
429 ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> ppNil)
430 ValSpecSpecIdCtxt n ty spec loc ->
432 \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
434 ----------------------------------------------------------------
435 specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> Error
437 specDataNoSpecErr name arg_tys locn
438 = addShortErrLocLine locn ( \ sty ->
440 ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
441 ppStr "... no unboxed type arguments in specialisation:"])
442 4 (ppAboves (map (ppr sty) arg_tys))
445 ----------------------------------------------------------------
446 specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> Error
448 specDataUnboxedErr name arg_tys locn
449 = addShortErrLocLine locn ( \ sty ->
451 ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
452 ppStr "... not all type arguments were specialised to",
453 ppStr "specific unboxed types or (boxed) type variables:"])
454 4 (ppAboves (map (ppr sty) arg_tys))
457 ----------------------------------------------------------------
458 specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> Error
460 specInstUnspecInstNotFoundErr clas inst_ty locn
461 = addErrLoc locn "No local instance to specialise" ( \ sty ->
462 ppBesides [ ppStr "class `", ppr sty clas, ppStr "' at the type `",
463 ppr sty inst_ty, ppStr "'"] )
465 ----------------------------------------------------------------
466 -- The type signatures on a mutually-recursive group of definitions
467 -- must all have the same context (or none). For example:
469 -- g :: (Eq a, Text a) => ...
470 -- is illegal if f and g are mutually recursive. This also
471 -- applies to variables bound in the same pattern binding.
473 sigContextsErr :: [SignatureInfo] -> Error
476 = dontAddErrLoc "A group of type signatures have mismatched contexts" ( \ sty ->
477 ppAboves (map (ppr_sig_info sty) infos) )
479 ppr_sig_info sty (TySigInfo val tyvars insts tau_ty _)
480 = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
481 4 (ppHang (if null insts
483 else ppBesides [ppStr "(", ppInterleave ppComma (map (ppr_inst sty) insts), ppStr ") => "])
487 = let (clas, ty) = getDictClassAndType inst
488 (locn, msg) = getInstOrigin inst
490 ppCat [ppr sty clas, ppr sty ty]
492 ----------------------------------------------------------------
493 topLevelUnboxedDeclErr :: Id -> SrcLoc -> Error
494 -- Top level decl of something with a primitive type
496 topLevelUnboxedDeclErr id locn
497 = addShortErrLocLine locn ( \ sty ->
498 ppBesides [ppStr "The top-level value `", ppr sty id, ppStr "' shouldn't have an unboxed type." ])
500 ----------------------------------------------------------------
501 dataConArityErr :: Id -> Int -> Int -> SrcLoc -> Error
502 tyConArityErr :: Name -> Int -> Int -> SrcLoc -> Error
504 tyConArityErr = arityError "Type"
505 dataConArityErr = arityError "Constructor"
507 arityError kind name n m locn =
508 addErrLoc locn errmsg
510 ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
511 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'])
513 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
514 quantity | m < n = "few"
516 n_arguments | n == 0 = ppStr "no arguments"
517 | n == 1 = ppStr "1 argument"
518 | True = ppCat [ppInt n, ppStr "arguments"]
520 ----------------------------------------------------------------
521 underAppliedTyErr :: UniType -> SrcLoc -> Error
522 underAppliedTyErr ty locn
523 = addErrLoc locn "A for-all type has been applied to too few arguments" ( \ sty ->
525 ppBesides [ppStr "The type is `", ppr sty ty, ppStr "';"],
526 ppStr "This might be because of a GHC bug; feel free to report",
527 ppStr "it to glasgow-haskell-bugs@dcs.glasgow.ac.uk."])
529 ----------------------------------------------------------------
530 unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error
532 unifyErr unify_err_info unify_err_context locn
533 = addShortErrLocLine locn ( \ sty ->
534 pprUnifyErrInfo sty unify_err_info unify_err_context)
536 ----------------------------------------------------------------
537 varyingArgsErr :: Name -> [RenamedMatch] -> Error
538 -- Different number of arguments in different equations
540 varyingArgsErr name matches
541 = dontAddErrLoc "Varying number of arguments for function" ( \ sty ->
544 varyingArgsErr name matches
545 = addErrLoc locn "Function Definition Error" ( \ sty ->
546 ppBesides [ppStr "Function `", ppr sty name, ppStr "' should have a fixed number of arguments" ])
550 %************************************************************************
552 \subsection[UnifyErr-types]{@UnifyErrInfo@ and @UnifyErrContext@ datatypes}
554 %************************************************************************
556 Here are the things that can go wrong during unification:
560 = UnifyMisMatch UniType UniType
561 | TypeRec TyVar TauType -- Occurs check failure
563 | UnifyListMisMatch [TauType] [TauType] -- Args to unifyList: diff lengths
564 -- produces system error
566 | UnifyUnboxedMisMatch UniType UniType -- No unboxed specialisation
570 @UnifyErrContext@ gives some context for unification
571 errors found in expressions. Also see the @UnifyErrInfo@ type (above),
572 as well as the general error-reporting type @Error@ (in @TcErrors@).
575 = PredCtxt RenamedExpr
576 | AppCtxt RenamedExpr RenamedExpr
578 | TooManyArgsCtxt RenamedExpr -- The offending function
579 -- We don't want the typechecked expr here,
580 -- because that may be full of
581 -- confusing dictionaries
583 | FunAppCtxt RenamedExpr -- The offending function
584 (Maybe Id) -- same info (probably) in a more convenient form
585 RenamedExpr -- The offending arg
586 UniType -- Expected type of offending arg
587 UniType -- Inferred type for offending arg
588 Int -- Which arg number (first is 1)
590 | OpAppCtxt RenamedExpr RenamedExpr RenamedExpr
591 | SectionLAppCtxt RenamedExpr RenamedExpr
592 | SectionRAppCtxt RenamedExpr RenamedExpr
593 | CaseCtxt RenamedExpr [RenamedMatch]
594 | BranchCtxt RenamedExpr RenamedExpr
595 | ListCtxt [RenamedExpr]
597 | CaseBranchesCtxt [RenamedMatch]
598 | FilterCtxt RenamedExpr
599 | GeneratorCtxt RenamedPat RenamedExpr
600 | GRHSsBranchCtxt [RenamedGRHS]
601 | GRHSsGuardCtxt RenamedExpr
602 | PatMonoBindsCtxt RenamedPat RenamedGRHSsAndBinds
603 | FunMonoBindsCtxt Name [RenamedMatch]
604 | MatchCtxt UniType UniType
605 | ArithSeqCtxt RenamedExpr
606 | CCallCtxt String [RenamedExpr]
607 | AmbigDictCtxt [Inst] -- Occurs check when simplifying ambiguous
608 -- dictionaries. Should never happen!
610 | MethodSigCtxt Name UniType
611 | ExprSigCtxt RenamedExpr UniType
612 | ValSpecSigCtxt Name UniType SrcLoc
613 | ValSpecSpecIdCtxt Name UniType Name SrcLoc
615 -- The next two contexts are associated only with TcSimplifyAndCheck failures
616 | BindSigCtxt [Id] -- Signature(s) for a group of bindings
617 | SuperClassSigCtxt -- Superclasses for this instance decl
619 | CaseBranchCtxt RenamedMatch
620 | Rank2ArgCtxt TypecheckedExpr UniType
622 | PodCtxt [RenamedExpr]
623 | ParFilterCtxt RenamedExpr
624 | DrawnCtxt [RenamedPat] RenamedPat RenamedExpr
625 | IndexCtxt [RenamedExpr] RenamedPat RenamedExpr
626 | ParPidPatCtxt RenamedPat
627 | ParPidExpCtxt RenamedExpr
628 | ParZFlhsCtxt RenamedExpr
629 #endif {- Data Parallel Haskell -}
632 %************************************************************************
634 \subsection[Errors-print-unify]{Printing unification error info}
636 %************************************************************************
639 ppUnifyErr :: Pretty -> Pretty -> Pretty
640 ppUnifyErr head rest = ppSep [head, {-if you want a blank line: ppSP,-} rest]
642 pprUnifyErrInfo sty (UnifyMisMatch mt1 mt2) err_ctxt
643 = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type `", ppr sty mt1, ppStr "'"],
644 ppBesides [ppStr "against `", ppr sty mt2, ppStr "'."]])
645 (pprUnifyErrContext sty err_ctxt)
647 pprUnifyErrInfo sty (TypeRec tyvar ty) err_ctxt
648 = ppUnifyErr (ppBesides [ppStr "Cannot construct the infinite type `",
650 ppStr "' = `",ppr sty ty, ppStr "' (\"occurs check\")."])
651 (pprUnifyErrContext sty err_ctxt)
653 pprUnifyErrInfo sty (UnifyListMisMatch tys1 tys2) err_ctxt
654 = panic "pprUnifyErrInfo: unifying lists of types of different lengths"
656 pprUnifyErrInfo sty (UnifyUnboxedMisMatch mt1 mt2) err_ctxt
657 = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type variable `", ppr sty mt1, ppStr "'"],
658 ppBesides [ppStr "against unboxed type `", ppr sty mt2, ppStr "'."],
659 ppStr "Try using -fspecialise-unboxed ..." ])
660 (pprUnifyErrContext sty err_ctxt)
663 %************************************************************************
665 \subsection[Errors-print-context]{Printing unification error context}
667 %************************************************************************
670 pp_nest_hang :: String -> Pretty -> Pretty
671 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
673 context = "Error detected when type-checking "
675 ppContext s = ppStr (context ++ s)
677 pprUnifyErrContext sty (PredCtxt e)
678 = ppHang (ppStr "In a predicate expression:") 4 (ppr sty e)
680 pprUnifyErrContext sty (AppCtxt f a)
681 = ppHang (ppStr "In a function application:") 4 (ppr sty (App f a))
683 pprUnifyErrContext sty (FunAppCtxt f maybe_id actual_arg expected_arg_ty actual_arg_ty n)
686 (have_extra_info, f_id, f_type)
688 Nothing -> (False, bottom, bottom)
689 Just id -> (True, id, getIdUniType id)
691 free_tyvars = extractTyVarsFromTy f_type
692 bottom = panic "no maybe_id"
695 ppHang (ppCat [ ppStr "In the", speakNth n, ppStr "argument of",
696 ppBesides [ppChar '`', ppr sty f, ppStr "',"] ])
697 4 (ppBesides [ppStr " namely `", ppr sty actual_arg, ppStr "'," ]),
699 ppHang (ppStr "Expected type of the argument: ")
700 4 (ppr sty expected_arg_ty),
702 ppHang (ppStr "Inferred type of the argument: ")
703 4 (ppr sty actual_arg_ty),
706 I'm not sure this adds anything
709 then ppHang (ppCat [ppStr "The type of",
710 ppBesides [ppChar '`', ppr sty f_id, ppChar '\''],
712 (ppBesides [ppChar '`', ppr sty f_type, ppStr "'."])
716 if not have_extra_info || null free_tyvars || isSysLocalId f_id
717 -- SysLocals are created for the local (monomorphic) versions
718 -- of recursive functions, and the monomorphism suggestion
719 -- below is sometimes positively misleading. Notably,
720 -- if you give an erroneous type sig, you may well end
721 -- up with a unification error like this, and it usually ain't due
726 ppSep [ppStr "Possible cause of error:",
727 ppBesides [ppChar '`', ppr sty f, ppChar '\''],
728 ppStr "is not polymorphic"],
729 ppSep [ppStr "it is monomorphic in the type variable(s):",
730 interpp'SP sty free_tyvars]
734 pprUnifyErrContext sty (TooManyArgsCtxt f)
735 = ppHang (ppStr "Too many arguments in an application of the function")
736 4 (ppBesides [ ppChar '`', ppr sty f, ppStr "'." ])
738 pprUnifyErrContext sty (SectionLAppCtxt expr op)
739 = ppHang (ppStr "In a left section:") 4 (ppr sty (SectionL expr op))
741 pprUnifyErrContext sty (SectionRAppCtxt op expr)
742 = ppHang (ppStr "In a right section:") 4 (ppr sty (SectionR op expr))
744 pprUnifyErrContext sty (OpAppCtxt a1 op a2)
745 = ppHang (ppStr "In an infix-operator application:") 4 (ppr sty (OpApp a1 op a2))
747 pprUnifyErrContext sty (CaseCtxt e as)
748 = ppHang (ppStr "In a case expression:") 4 (ppr sty (Case e as))
750 pprUnifyErrContext sty (BranchCtxt b1 b2)
751 = ppSep [ppStr "In the branches of a conditional:",
752 pp_nest_hang "`then' branch:" (ppr sty b1),
753 pp_nest_hang "`else' branch:" (ppr sty b2)]
755 pprUnifyErrContext sty (ListCtxt es)
756 = ppHang (ppStr "In a list expression:") 4 (
757 ppBesides [ppLbrack, interpp'SP sty es, ppRbrack])
759 pprUnifyErrContext sty (PatCtxt (ConPatIn name pats))
760 = ppHang (ppStr "In a constructed pattern:")
761 4 (ppCat [ppr sty name, interppSP sty pats])
763 pprUnifyErrContext sty (PatCtxt (ConOpPatIn pat1 op pat2))
764 = ppHang (ppStr "In an infix-operator pattern:")
765 4 (ppCat [ppr sty pat1, ppr sty op, ppr sty pat2])
767 pprUnifyErrContext sty (PatCtxt (ListPatIn ps))
768 = ppHang (ppStr "In an explicit list pattern:")
769 4 (ppBesides [ppLbrack, interpp'SP sty ps, ppRbrack])
771 pprUnifyErrContext sty (PatCtxt pat@(AsPatIn _ _))
772 = ppHang (ppStr "In an as-pattern:") 4 (ppr sty pat)
774 pprUnifyErrContext sty (CaseBranchesCtxt (m:ms))
775 = ppAboves [ppStr "Inside two case alternatives:",
776 ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) [m])),
777 ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) ms))]
779 pprUnifyErrContext sty (FilterCtxt e)
780 = ppHang (ppStr "In a guard in a list-comprehension:") 4 (ppr sty e)
782 pprUnifyErrContext sty (GeneratorCtxt p e)
783 = ppHang (ppStr "In a generator in a list-comprehension:")
784 4 (ppSep [ppr sty p, ppStr "<-", ppr sty e])
786 pprUnifyErrContext sty (GRHSsBranchCtxt grhss)
787 = ppAboves [ppStr "In some guarded right-hand-sides:",
788 ppNest 4 (ppAboves (map (pprGRHS sty False) grhss))]
790 pprUnifyErrContext sty (GRHSsGuardCtxt g)
791 = ppHang (ppStr "In a guard on an equation:") 4 (ppr sty g)
793 pprUnifyErrContext sty (PatMonoBindsCtxt pat grhss_and_binds)
794 = ppHang (ppStr "In a pattern binding:")
795 4 (ppr sty (PatMonoBind pat grhss_and_binds mkUnknownSrcLoc))
797 pprUnifyErrContext sty (FunMonoBindsCtxt id matches)
798 = ppHang (ppStr "When combining a function's equation(s) & type signature (if applicable):")
799 4 (ppBesides [ppr sty id, ppSP, pprMatches sty (False,ppNil) matches])
801 pprUnifyErrContext sty (CaseBranchCtxt match)
802 = ppHang (ppStr "When combining a \"case\" branch & type signature (if applicable):")
803 4 (pprMatch sty True{-is_case-} match)
805 pprUnifyErrContext sty (MatchCtxt ty1 ty2)
806 = ppAboves [ppStr "In a type signature:",
807 pp_nest_hang "Signature:" (ppr sty ty1),
808 pp_nest_hang "Inferred type:" (ppr sty ty2)]
810 pprUnifyErrContext sty (ArithSeqCtxt expr)
811 = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
813 pprUnifyErrContext sty (CCallCtxt label args)
814 = ppAboves [ppStr "In a _ccall_ or _casm_:",
815 pp_nest_hang "C-calling magic:" (ppStr label),
816 pp_nest_hang "Arguments:" (ppInterleave ppComma (map (ppr sty) args))]
819 pprUnifyErrContext sty (AmbigDictCtxt dicts)
820 = ppStr "Ambiguous dictionary occurs check: should never happen!"
822 pprUnifyErrContext sty (SigCtxt id tau_ty)
823 = ppHang (ppBesides [ppStr "In the type signature for ",
828 pprUnifyErrContext sty (MethodSigCtxt name ty)
829 = ppHang (ppBesides [ ppStr "When matching the definition of class method `",
830 ppr sty name, ppStr "' to its signature :" ]
833 pprUnifyErrContext sty (ExprSigCtxt expr ty)
834 = ppHang (ppStr "In an expression with a type signature:")
835 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
838 pprUnifyErrContext sty (BindSigCtxt ids)
839 = ppHang (ppStr "When checking type signatures for: ")
840 4 (ppInterleave (ppStr ", ") (map (ppr sty) ids))
842 pprUnifyErrContext sty SuperClassSigCtxt
843 = ppStr "When checking superclass constraints on instance declaration"
845 pprUnifyErrContext sty (Rank2ArgCtxt expr ty)
846 = ppHang (ppStr "In an argument which has rank-2 polymorphic type:")
847 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
850 pprUnifyErrContext sty (ValSpecSigCtxt v ty src_loc)
851 = ppHang (ppStr "In a SPECIALIZE pragma for a value:")
852 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
855 pprUnifyErrContext sty (ValSpecSpecIdCtxt v ty spec src_loc)
856 = ppHang (ppStr "When checking type of explicit id in SPECIALIZE pragma:")
857 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
859 ppBeside (ppStr " = ") (ppr sty spec)])
862 pprUnifyErrContext sty (PodCtxt es)
863 = ppAboves [ppStr "In a POD expression:",
864 ppBesides [ppStr "<<", interpp'SP sty es, ppStr ">>"]]
866 pprUnifyErrContext sty (ParFilterCtxt e)
867 = ppHang (ppStr "In a guard of a POD comprehension:") 4
870 pprUnifyErrContext sty (DrawnCtxt ps p e)
871 = ppHang (ppStr "In parallel drawn from generator:")
872 4 (ppSep [ppStr "(|" ,interpp'SP sty ps, ppStr ";" ,
873 ppr sty p ,ppStr "|)", ppStr "<<-", ppr sty e])
875 pprUnifyErrContext sty (IndexCtxt es p e)
876 = ppHang (ppStr "In parallel index from generator:")
877 4 (ppSep [ppStr "(|",interpp'SP sty es, ppStr ";" ,
878 ppr sty p ,ppStr "|)" , ppStr "<<=", ppr sty e])
880 pprUnifyErrContext sty (ParPidPatCtxt p)
881 = ppHang (ppStr "In pattern for processor ID has to be in class Pid:")
884 pprUnifyErrContext sty (ParPidExpCtxt e)
885 = ppHang (ppStr "In expression for processor ID has to be in class Pid:")
888 pprUnifyErrContext sty (ParZFlhsCtxt e)
889 = ppHang (ppStr "In LHS of a POD comprehension has to be in class Processor")
892 #endif {- Data Parallel Haskell -}
897 pprPodizedWarning :: PodWarning -> Error
898 pprPodizedWarning (EntryNotPodized b)
899 = addWarningLoc (getSrcLoc b) (\ sty ->
900 ppBeside (ppStr "Unable to parallelise entry: ")
904 pprPodizedWarning (NoGoNestedPodized b)
905 = addWarningLoc (getSrcLoc b) (\ sty ->
906 ppBeside (ppStr "Sorry no nested parallelism yet: ")
910 pprPodizedWarning (ContextNotAvailable b c)
911 = addWarningLoc (getSrcLoc b) (\ sty ->
912 ppAbove (ppBesides [ppStr "No parallelisation of binding for a ",
913 ppStr (show_context c) , ppStr ": ",ppr sty b])
914 (ppBesides [ppStr "Maybe you should re-compile this module ",
915 ppStr "with the `",ppStr (which_flag c),
919 pprPodizedWarning (ImportNotAvailable b c)
920 = addWarningLoc (getSrcLoc b) (\ sty ->
921 ppAboves [ppBesides [ppStr "No parallelisation of binding for a ",
922 ppStr (show_context c),ppStr ": ", ppr sty b],
923 ppBesides [ppStr "If you re-compile the module `",
924 ppStr (fst (getOrigName b)), ppStr "`"],
925 ppBesides [ppStr "with the `",ppStr (which_flag c),
926 ppStr "' flag I may do a better job :-)"]]
930 pprPodizedWarning (ArgsInDifferentContexts b)
931 = addWarningLoc (getSrcLoc b) (\ sty ->
932 ppBesides [ppStr "Higher Order argument used in different ",
933 ppStr "parallel contexts : ",ppr sty b]
936 pprPodizedWarning (NoPodization)
937 = addWarning (\ sty ->
938 ppStr "Program not podized")
940 pprPodizedWarning (PodizeStats ci pi vl pl)
941 = addWarning (\ sty ->
942 (ppHang (ppStr "Podization Statistics:")
944 (ppAboves [ppCat [ppStr "Info collecting passes =",ppr sty ci],
945 ppCat [ppStr "Podization passes =",ppr sty pi],
946 ppCat [ppStr "Vanilla's deleted =",ppr sty vl],
947 ppCat [ppStr "Podized deleted =",ppr sty pl]]))
950 show_context :: Int -> String
951 show_context 1 = "\"vector\""
952 show_context 2 = "\"matrix\""
953 show_context 3 = "\"cube\""
954 show_context n = "\""++(show n)++"-D Pod\""
956 which_flag :: Int -> String
957 which_flag 1 = "-fpodize-vector"
958 which_flag 2 = "-fpodize-matrix"
959 which_flag 3 = "-fpodize-cube"
960 #endif {- Data Parallel Haskell -}
964 @speakNth@ converts an integer to a verbal index; eg 1 maps to ``first'' etc.
966 speakNth :: Int -> Pretty
967 speakNth 1 = ppStr "first"
968 speakNth 2 = ppStr "second"
969 speakNth 3 = ppStr "third"
970 speakNth 4 = ppStr "fourth"
971 speakNth 5 = ppStr "fifth"
972 speakNth 6 = ppStr "sixth"
973 speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
975 st_nd_rd_th | n_rem_10 == 1 = "st"
976 | n_rem_10 == 2 = "nd"
977 | n_rem_10 == 3 = "rd"
980 n_rem_10 = n `rem` 10