ghc/compiler/main/ErrsTc.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1995
   3 %
   4 \section[ErrsTc]{Reporting errors from the typechecker}
   5
   6 This is an internal module---access to these functions is through
   7 @Errors@.
   8
   9 DPH errors are in here, too.
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13
  14 module ErrsTc (
  15         UnifyErrContext(..), UnifyErrInfo(..),
  16
  17         ambigErr,
  18         badMatchErr,
  19         badSpecialisationErr,
  20         classCycleErr,
  21         confusedNameErr,
  22         dataConArityErr,
  23         defaultErr,
  24         derivingEnumErr,
  25         derivingIxErr,
  26         derivingWhenInstanceExistsErr,
  27         dupInstErr,
  28         genCantGenErr,
  29         instTypeErr,
  30         lurkingRank2Err,
  31         methodTypeLacksTyVarErr,
  32         naughtyCCallContextErr,
  33         noInstanceErr,
  34         nonBoxedPrimCCallErr,
  35         notAsPolyAsSigErr,
  36         preludeInstanceErr,
  37         reduceErr,
  38         sigContextsErr,
  39         specCtxtGroundnessErr,
  40         specDataNoSpecErr,
  41         specDataUnboxedErr,
  42         specGroundnessErr,
  43         specInstUnspecInstNotFoundErr,
  44         topLevelUnboxedDeclErr,
  45         tyConArityErr,
  46         typeCycleErr,
  47         underAppliedTyErr,
  48         unifyErr,
  49         varyingArgsErr
  50     ) where
  51
  52 import AbsSyn           -- we print a bunch of stuff in here
  53 import UniType          ( UniType(..) )         -- Concrete, to make some errors
  54                                                 -- more informative.
  55 import ErrUtils
  56 import AbsUniType       ( extractTyVarsFromTy, pprMaybeTy,
  57                           TyVar, TyVarTemplate, TyCon,
  58                           TauType(..), Class, ClassOp
  59                           IF_ATTACK_PRAGMAS(COMMA pprUniType)
  60                         )
  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 )
  67 import Outputable
  68 import Pretty           -- to pretty-print error messages
  69 #ifdef DPH
  70 import PodizeMonad      ( PodWarning(..) )
  71 #endif {- Data Parallel Haskell -}
  72 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  73 import Util
  74 \end{code}
  75
  76 \begin{code}
  77 ambigErr :: [Inst] -> Error
  78 ambigErr insts@(inst1:_)
  79   = addErrLoc loc1 "Ambiguous overloading" ( \ sty ->
  80     ppAboves (map (ppr_inst sty) insts) )
  81   where
  82     (loc1, _) = getInstOrigin inst1
  83
  84 ppr_inst sty inst
  85   = let
  86         (clas, ty)  = getDictClassAndType inst
  87         (locn, msg) = getInstOrigin inst
  88     in
  89     ppSep [ ppBesides [ppStr "class `", ppr sty clas,
  90                        ppStr "', type `", ppr sty ty, ppStr "'"],
  91             ppBesides [ppStr "(", msg sty, ppStr ")"] ]
  92
  93 ----------------------------------------------------------------
  94 badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> Error
  95 badMatchErr sig_ty inferred_ty ctxt locn
  96   = addErrLoc locn "Type signature mismatch" ( \ sty ->
  97     let
  98         thing
  99           = case ctxt of
 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
 106     in
 107     ppAboves [ppSep [
 108                 ppStr "Signature for", thing, ppStr "doesn't match its inferred type."
 109               ],
 110               ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
 111               ppHang (ppStr "Inferred type:") 4 (ppr sty inferred_ty)
 112     ] )
 113
 114 ----------------------------------------------------------------
 115 badSpecialisationErr :: String -> String -> Int -> [Maybe UniType] -> SrcLoc -> Error
 116
 117 badSpecialisationErr flavor messg no_tyvars ty_maybes locn
 118   = addErrLoc locn ("Bad "++flavor++" specialisation pragma: "++messg)  ( \ sty ->
 119     ppStr "MSG NOT DONE YET"
 120     )
 121
 122 ----------------------------------------------------------------
 123 confusedNameErr :: String
 124                 -> Name         -- the confused name
 125                 -> SrcLoc
 126                 -> Error
 127 confusedNameErr msg nm locn
 128   = addErrLoc locn msg ( \ sty ->
 129     ppr sty nm )
 130 {-
 131   where
 132     msg = if flag then "Type constructor used where a class is expected"
 133                   else "Class used where a type constructor is expected"
 134 -}
 135
 136 ----------------------------------------------------------------
 137 typeCycleErr :: [[(Pretty, SrcLoc)]] -> Error
 138 typeCycleErr = cycleErr  "The following type synonyms refer to themselves:"
 139
 140 classCycleErr :: [[(Pretty, SrcLoc)]] -> Error
 141 classCycleErr = cycleErr  "The following classes form a cycle:"
 142
 143 cycleErr :: String -> [[(Pretty, SrcLoc)]] -> Error
 144 cycleErr msg cycles sty
 145  = ppHang (ppStr msg)
 146         4 (ppAboves (map pp_cycle cycles))
 147  where
 148    pp_cycle things      = ppAboves (map pp_thing things)
 149    pp_thing (thing,loc) = ppHang (ppBesides [ppr PprForUser loc, ppStr ": "]) 4 thing
 150
 151 ----------------------------------------------------------------
 152 defaultErr :: [Inst]{-dicts-} -> [UniType] -> Error
 153         -- when default-resolution fails...
 154
 155 defaultErr dicts defaulting_tys sty
 156   = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
 157          4 (ppAboves [
 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.)" ])
 163
 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 "'"] )
 169
 170 ----------------------------------------------------------------
 171 derivingIxErr :: TyCon -> Error
 172 derivingIxErr tycon
 173   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
 174     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 175
 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 "'"] )
 182
 183 ----------------------------------------------------------------
 184 {- UNUSED:
 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 "')"]
 191           ])
 192 -}
 193
 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] )
 201
 202 ----------------------------------------------------------------
 203 {- UNUSED?
 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 )
 209 -}
 210
 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) )
 216   where
 217     (loc1, _) = getInstOrigin inst1
 218
 219 ----------------------------------------------------------------
 220 {- UNUSED:
 221 genPrimTyVarErr :: [TyVar] -> SrcLoc -> Error
 222         -- Attempt to generalise over a primitive type variable
 223
 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.)") )
 228 -}
 229 ----------------------------------------------------------------
 230 noInstanceErr :: Inst -> Error
 231 noInstanceErr inst
 232   = let (clas, ty)  = getDictClassAndType inst
 233         (locn, msg) = getInstOrigin inst
 234     in
 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 ")"] ]
 239     )
 240
 241 ----------------------------------------------------------------
 242 {- UNUSED:
 243 instOpErr :: Id -> Class -> TyCon -> Error
 244
 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 '\'' ] )
 254 -}
 255
 256 ----------------------------------------------------------------
 257 instTypeErr :: UniType -> SrcLoc -> Error
 258 instTypeErr ty locn
 259   = addShortErrLocLine locn (\ sty ->
 260     let
 261         rest_of_msg = ppStr "' cannot be used as the instance type\n    in an instance declaration."
 262     in
 263     case ty of
 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]
 267     )
 268
 269 ----------------------------------------------------------------
 270 lurkingRank2Err :: Name -> UniType -> SrcLoc -> Error
 271 lurkingRank2Err name ty locn
 272   = addErrLoc locn "Illegal use of a non-Hindley-Milner variable" ( \ sty ->
 273     ppAboves [
 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.)"])
 279
 280 ----------------------------------------------------------------
 281 {- UNUSED:
 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)
 287 -}
 288
 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)]
 294
 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)] )
 301
 302 ----------------------------------------------------------------
 303 {- UNUSED:
 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 ] )
 309 -}
 310
 311 ----------------------------------------------------------------
 312 naughtyCCallContextErr :: Name -> SrcLoc -> Error
 313 naughtyCCallContextErr clas_name locn
 314   = addErrLoc locn "Can't use this class in a context" (\ sty ->
 315     ppr sty clas_name )
 316
 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 "'"] )
 323
 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"
 333         ] )
 334
 335 ----------------------------------------------------------------
 336 {- UNUSED:
 337 patMatchWithPrimErr :: Error
 338 patMatchWithPrimErr
 339   = dontAddErrLoc
 340         "Pattern-bindings may not involve primitive types." ( \ sty ->
 341         ppNil )
 342 -}
 343
 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)") )
 351
 352 ----------------------------------------------------------------
 353 {- UNUSED:
 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."] )
 359 -}
 360
 361 ----------------------------------------------------------------
 362 reduceErr :: [Inst] -> UnifyErrContext -> Error
 363         -- Used by tcSimplifyCheckLIE
 364         -- Could not express required dictionaries in terms of the signature
 365 reduceErr insts ctxt
 366   = dontAddErrLoc "Type signature lacks context required by inferred type" ( \ sty ->
 367     ppAboves [
 368         pprUnifyErrContext sty ctxt,
 369         ppHang (ppStr "Context reqd: ")
 370              4 (ppAboves (map (ppr_inst sty) insts))
 371     ])
 372   where
 373     ppr_inst sty inst
 374       = let (clas, ty)  = getDictClassAndType inst
 375             (locn, msg) = getInstOrigin inst
 376         in
 377         ppSep [ ppBesides [ppr sty locn, ppStr ": ", ppr sty clas, ppSP, ppr sty ty],
 378                 ppBesides [ppStr "(", msg sty, ppStr ")"] ]
 379
 380 ----------------------------------------------------------------
 381 {-
 382 unexpectedPreludeThingErr :: Outputable a => String -> a -> SrcLoc -> Error
 383
 384 unexpectedPreludeThingErr category thing locn
 385   = addShortErrLocLine locn ( \ sty ->
 386     ppBesides [ppStr "Prelude ", ppStr category,
 387                ppStr " not expected here: ", ppr sty thing])
 388 -}
 389
 390 ----------------------------------------------------------------
 391 specGroundnessErr :: UnifyErrContext -> [UniType] -> Error
 392
 393 specGroundnessErr (ValSpecSigCtxt name spec_ty locn) arg_tys
 394   = addShortErrLocLine locn ( \ sty ->
 395     ppHang (
 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))
 400     )
 401
 402 specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys
 403   = addShortErrLocLine locn ( \ sty ->
 404     ppHang (
 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))
 410     )
 411
 412 ----------------------------------------------------------------
 413 specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> Error
 414
 415 specCtxtGroundnessErr err_ctxt dicts
 416   = addShortErrLocLine locn ( \ sty ->
 417     ppHang (
 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 "'"],
 420                pp_spec_id sty,
 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])
 425     )
 426   where
 427     (name, spec_ty, locn, pp_spec_id)
 428       = case err_ctxt of
 429           ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
 430           ValSpecSpecIdCtxt n ty spec loc ->
 431             (n, ty, loc,
 432              \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
 433
 434 ----------------------------------------------------------------
 435 specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> Error
 436
 437 specDataNoSpecErr name arg_tys locn
 438   = addShortErrLocLine locn ( \ sty ->
 439     ppHang (
 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))
 443     )
 444
 445 ----------------------------------------------------------------
 446 specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> Error
 447
 448 specDataUnboxedErr name arg_tys locn
 449   = addShortErrLocLine locn ( \ sty ->
 450     ppHang (
 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))
 455     )
 456
 457 ----------------------------------------------------------------
 458 specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> Error
 459
 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 "'"] )
 464
 465 ----------------------------------------------------------------
 466 -- The type signatures on a mutually-recursive group of definitions
 467 -- must all have the same context (or none).  For example:
 468 --      f :: Eq a => ...
 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.
 472
 473 sigContextsErr :: [SignatureInfo] -> Error
 474
 475 sigContextsErr infos
 476   = dontAddErrLoc "A group of type signatures have mismatched contexts" ( \ sty ->
 477     ppAboves (map (ppr_sig_info sty) infos) )
 478   where
 479     ppr_sig_info sty (TySigInfo val tyvars insts tau_ty _)
 480       = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
 481              4 (ppHang (if null insts
 482                         then ppNil
 483                         else ppBesides [ppStr "(", ppInterleave ppComma (map (ppr_inst sty) insts), ppStr ") => "])
 484                      4 (ppr sty tau_ty))
 485
 486     ppr_inst sty inst
 487       = let (clas, ty)  = getDictClassAndType inst
 488             (locn, msg) = getInstOrigin inst
 489         in
 490         ppCat [ppr sty clas, ppr sty ty]
 491
 492 ----------------------------------------------------------------
 493 topLevelUnboxedDeclErr :: Id -> SrcLoc -> Error
 494         -- Top level decl of something with a primitive type
 495
 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." ])
 499
 500 ----------------------------------------------------------------
 501 dataConArityErr :: Id   -> Int -> Int -> SrcLoc -> Error
 502 tyConArityErr   :: Name -> Int -> Int -> SrcLoc -> Error
 503
 504 tyConArityErr   = arityError "Type"
 505 dataConArityErr = arityError "Constructor"
 506
 507 arityError kind name n m locn =
 508     addErrLoc locn errmsg
 509     (\ sty ->
 510     ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
 511                 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'])
 512     where
 513         errmsg = kind ++ " has too " ++ quantity ++ " arguments"
 514         quantity | m < n     = "few"
 515                  | otherwise = "many"
 516         n_arguments | n == 0 = ppStr "no arguments"
 517                     | n == 1 = ppStr "1 argument"
 518                     | True   = ppCat [ppInt n, ppStr "arguments"]
 519
 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 ->
 524     ppAboves [
 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."])
 528
 529 ----------------------------------------------------------------
 530 unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error
 531
 532 unifyErr unify_err_info unify_err_context locn
 533   = addShortErrLocLine locn ( \ sty ->
 534     pprUnifyErrInfo sty unify_err_info unify_err_context)
 535
 536 ----------------------------------------------------------------
 537 varyingArgsErr :: Name -> [RenamedMatch] -> Error
 538         -- Different number of arguments in different equations
 539
 540 varyingArgsErr name matches
 541   = dontAddErrLoc "Varying number of arguments for function" ( \ sty ->
 542     ppr sty name )
 543 {-
 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" ])
 547 -}
 548 \end{code}
 549
 550 %************************************************************************
 551 %*                                                                      *
 552 \subsection[UnifyErr-types]{@UnifyErrInfo@ and @UnifyErrContext@ datatypes}
 553 %*                                                                      *
 554 %************************************************************************
 555
 556 Here are the things that can go wrong during unification:
 557
 558 \begin{code}
 559 data UnifyErrInfo
 560   = UnifyMisMatch       UniType UniType
 561   | TypeRec             TyVar   TauType         -- Occurs check failure
 562
 563   | UnifyListMisMatch   [TauType] [TauType]     -- Args to unifyList: diff lengths
 564                                                 -- produces system error
 565
 566   | UnifyUnboxedMisMatch UniType UniType        -- No unboxed specialisation
 567
 568 \end{code}
 569
 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@).
 573 \begin{code}
 574 data UnifyErrContext
 575   = PredCtxt            RenamedExpr
 576   | AppCtxt             RenamedExpr RenamedExpr
 577
 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
 582
 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)
 589
 590   | OpAppCtxt           RenamedExpr RenamedExpr RenamedExpr
 591   | SectionLAppCtxt     RenamedExpr RenamedExpr
 592   | SectionRAppCtxt     RenamedExpr RenamedExpr
 593   | CaseCtxt            RenamedExpr [RenamedMatch]
 594   | BranchCtxt          RenamedExpr RenamedExpr
 595   | ListCtxt            [RenamedExpr]
 596   | PatCtxt             RenamedPat
 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!
 609   | SigCtxt             Id UniType
 610   | MethodSigCtxt       Name UniType
 611   | ExprSigCtxt         RenamedExpr UniType
 612   | ValSpecSigCtxt      Name UniType SrcLoc
 613   | ValSpecSpecIdCtxt   Name UniType Name SrcLoc
 614
 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
 618
 619   | CaseBranchCtxt      RenamedMatch
 620   | Rank2ArgCtxt        TypecheckedExpr UniType
 621 #ifdef DPH
 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 -}
 630 \end{code}
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsection[Errors-print-unify]{Printing unification error info}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638 \begin{code}
 639 ppUnifyErr :: Pretty -> Pretty -> Pretty
 640 ppUnifyErr head rest = ppSep [head, {-if you want a blank line: ppSP,-} rest]
 641
 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)
 646
 647 pprUnifyErrInfo sty (TypeRec tyvar ty) err_ctxt
 648  = ppUnifyErr (ppBesides [ppStr "Cannot construct the infinite type `",
 649                                  ppr sty tyvar,
 650                                  ppStr "' = `",ppr sty ty, ppStr "' (\"occurs check\")."])
 651               (pprUnifyErrContext sty err_ctxt)
 652
 653 pprUnifyErrInfo sty (UnifyListMisMatch tys1 tys2) err_ctxt
 654  = panic "pprUnifyErrInfo: unifying lists of types of different lengths"
 655
 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)
 661 \end{code}
 662
 663 %************************************************************************
 664 %*                                                                      *
 665 \subsection[Errors-print-context]{Printing unification error context}
 666 %*                                                                      *
 667 %************************************************************************
 668
 669 \begin{code}
 670 pp_nest_hang :: String -> Pretty -> Pretty
 671 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 672
 673 context = "Error detected when type-checking "
 674
 675 ppContext s = ppStr (context ++ s)
 676
 677 pprUnifyErrContext sty (PredCtxt e)
 678   = ppHang (ppStr "In a predicate expression:") 4 (ppr sty e)
 679
 680 pprUnifyErrContext sty (AppCtxt f a)
 681   = ppHang (ppStr "In a function application:") 4 (ppr sty (App f a))
 682
 683 pprUnifyErrContext sty (FunAppCtxt f maybe_id actual_arg expected_arg_ty actual_arg_ty n)
 684   = let
 685
 686         (have_extra_info, f_id, f_type)
 687            = case maybe_id of
 688                Nothing -> (False, bottom, bottom)
 689                Just id -> (True,  id, getIdUniType id)
 690
 691         free_tyvars = extractTyVarsFromTy f_type
 692         bottom = panic "no maybe_id"
 693     in
 694     ppAboves [
 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 "'," ]),
 698
 699         ppHang  (ppStr "Expected type of the argument: ")
 700                 4 (ppr sty expected_arg_ty),
 701
 702         ppHang  (ppStr "Inferred type of the argument: ")
 703                 4 (ppr sty actual_arg_ty),
 704
 705 {- OMIT
 706    I'm not sure this adds anything
 707
 708         if have_extra_info
 709         then ppHang (ppCat [ppStr "The type of",
 710                             ppBesides [ppChar '`', ppr sty f_id, ppChar '\''],
 711                             ppStr "is"]) 4
 712                     (ppBesides [ppChar '`', ppr sty f_type, ppStr "'."])
 713         else ppNil,
 714 -}
 715
 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
 722                 -- to monomorphism.
 723         then ppNil
 724         else
 725            ppAboves [
 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]
 731            ]
 732     ]
 733
 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 "'." ])
 737
 738 pprUnifyErrContext sty (SectionLAppCtxt expr op)
 739   = ppHang (ppStr "In a left section:")  4 (ppr sty (SectionL expr op))
 740
 741 pprUnifyErrContext sty (SectionRAppCtxt op expr)
 742   = ppHang (ppStr "In a right section:") 4 (ppr sty (SectionR op expr))
 743
 744 pprUnifyErrContext sty (OpAppCtxt a1 op a2)
 745   = ppHang (ppStr "In an infix-operator application:") 4 (ppr sty (OpApp a1 op a2))
 746
 747 pprUnifyErrContext sty (CaseCtxt e as)
 748   = ppHang (ppStr "In a case expression:") 4 (ppr sty (Case e as))
 749
 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)]
 754
 755 pprUnifyErrContext sty (ListCtxt es)
 756   = ppHang (ppStr "In a list expression:") 4 (
 757               ppBesides [ppLbrack, interpp'SP sty es, ppRbrack])
 758
 759 pprUnifyErrContext sty (PatCtxt (ConPatIn name pats))
 760   = ppHang (ppStr "In a constructed pattern:")
 761          4 (ppCat [ppr sty name, interppSP sty pats])
 762
 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])
 766
 767 pprUnifyErrContext sty (PatCtxt (ListPatIn ps))
 768   = ppHang (ppStr "In an explicit list pattern:")
 769          4 (ppBesides [ppLbrack, interpp'SP sty ps, ppRbrack])
 770
 771 pprUnifyErrContext sty (PatCtxt pat@(AsPatIn _ _))
 772   = ppHang (ppStr "In an as-pattern:") 4 (ppr sty pat)
 773
 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))]
 778
 779 pprUnifyErrContext sty (FilterCtxt e)
 780   = ppHang (ppStr "In a guard in a list-comprehension:") 4 (ppr sty e)
 781
 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])
 785
 786 pprUnifyErrContext sty (GRHSsBranchCtxt grhss)
 787   = ppAboves [ppStr "In some guarded right-hand-sides:",
 788               ppNest 4 (ppAboves (map (pprGRHS sty False) grhss))]
 789
 790 pprUnifyErrContext sty (GRHSsGuardCtxt g)
 791   = ppHang (ppStr "In a guard on an equation:") 4 (ppr sty g)
 792
 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))
 796
 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])
 800
 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)
 804
 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)]
 809
 810 pprUnifyErrContext sty (ArithSeqCtxt expr)
 811   = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
 812
 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))]
 817
 818 -- OLD: kill
 819 pprUnifyErrContext sty (AmbigDictCtxt dicts)
 820   = ppStr "Ambiguous dictionary occurs check: should never happen!"
 821
 822 pprUnifyErrContext sty (SigCtxt id tau_ty)
 823   = ppHang (ppBesides [ppStr "In the type signature for ",
 824                    ppr sty id,
 825                    ppStr ":"]
 826            ) 4 (ppr sty tau_ty)
 827
 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 :" ]
 831            ) 4 (ppr sty ty)
 832
 833 pprUnifyErrContext sty (ExprSigCtxt expr ty)
 834   = ppHang (ppStr "In an expression with a type signature:")
 835          4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
 836                   ppr sty ty])
 837
 838 pprUnifyErrContext sty (BindSigCtxt ids)
 839   = ppHang (ppStr "When checking type signatures for: ")
 840          4 (ppInterleave (ppStr ", ") (map (ppr sty) ids))
 841
 842 pprUnifyErrContext sty SuperClassSigCtxt
 843   = ppStr "When checking superclass constraints on instance declaration"
 844
 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 " ::"),
 848                   ppr sty ty])
 849
 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 " ::"),
 853                   ppr sty ty])
 854
 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 " ::"),
 858                   ppr sty ty,
 859                   ppBeside (ppStr " = ") (ppr sty spec)])
 860
 861 #ifdef DPH
 862 pprUnifyErrContext sty (PodCtxt es)
 863   = ppAboves [ppStr "In a POD expression:",
 864               ppBesides [ppStr "<<", interpp'SP sty es, ppStr ">>"]]
 865
 866 pprUnifyErrContext sty (ParFilterCtxt e)
 867   = ppHang (ppStr "In a guard of a POD comprehension:") 4
 868            (ppr sty e)
 869
 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])
 874
 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])
 879
 880 pprUnifyErrContext sty (ParPidPatCtxt p)
 881   = ppHang (ppStr "In pattern for processor ID has to be in class Pid:")
 882            4 (ppr sty p)
 883
 884 pprUnifyErrContext sty (ParPidExpCtxt e)
 885   = ppHang (ppStr "In expression for processor ID has to be in class Pid:")
 886            4 (ppr sty e)
 887
 888 pprUnifyErrContext sty (ParZFlhsCtxt e)
 889   = ppHang (ppStr "In LHS of a POD comprehension has to be in class Processor")
 890            4 (ppr sty e)
 891
 892 #endif {- Data Parallel Haskell -}
 893 \end{code}
 894
 895 \begin{code}
 896 #ifdef DPH
 897 pprPodizedWarning :: PodWarning -> Error
 898 pprPodizedWarning (EntryNotPodized b)
 899    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 900      ppBeside (ppStr "Unable to parallelise entry: ")
 901               (ppr sty b)
 902      )
 903
 904 pprPodizedWarning (NoGoNestedPodized b)
 905    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 906      ppBeside (ppStr "Sorry no nested parallelism yet: ")
 907               (ppr sty b)
 908    )
 909
 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),
 916                          ppStr "' flag."])
 917      )
 918
 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 :-)"]]
 927      )
 928
 929
 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]
 934      )
 935
 936 pprPodizedWarning (NoPodization)
 937    = addWarning                                                 (\ sty ->
 938      ppStr "Program not podized")
 939
 940 pprPodizedWarning (PodizeStats ci pi vl pl)
 941    = addWarning                                                 (\ sty ->
 942      (ppHang (ppStr "Podization Statistics:")
 943              5
 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]]))
 948      )
 949
 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\""
 955
 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 -}
 961 \end{code}
 962
 963
 964 @speakNth@ converts an integer to a verbal index; eg 1 maps to ``first'' etc.
 965 \begin{code}
 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 ]
 974   where
 975     st_nd_rd_th | n_rem_10 == 1 = "st"
 976                 | n_rem_10 == 2 = "nd"
 977                 | n_rem_10 == 3 = "rd"
 978                 | otherwise     = "th"
 979
 980     n_rem_10 = n `rem` 10
 981 \end{code}