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         methodTypeLacksTyVarErr,
  31         naughtyCCallContextErr,
  32         noInstanceErr,
  33         nonBoxedPrimCCallErr,
  34         notAsPolyAsSigErr,
  35         preludeInstanceErr,
  36         reduceErr,
  37         sigContextsErr,
  38         specCtxtGroundnessErr,
  39         specDataNoSpecErr,
  40         specDataUnboxedErr,
  41         specGroundnessErr,
  42         specInstUnspecInstNotFoundErr,
  43         topLevelUnboxedDeclErr,
  44         tyConArityErr,
  45         typeCycleErr,
  46         unifyErr,
  47         varyingArgsErr
  48     ) where
  49
  50 import AbsSyn           -- we print a bunch of stuff in here
  51 import UniType          ( UniType(..) )         -- Concrete, to make some errors
  52                                                 -- more informative.
  53 import ErrUtils
  54 import AbsUniType       ( extractTyVarsFromTy, pprMaybeTy,
  55                           TyVar, TyVarTemplate, TyCon,
  56                           TauType(..), Class, ClassOp
  57                           IF_ATTACK_PRAGMAS(COMMA pprUniType)
  58                         )
  59 import Bag              ( Bag, bagToList )
  60 import GenSpecEtc       ( SignatureInfo(..) )
  61 import HsMatches        ( pprMatches, pprMatch, pprGRHS )
  62 import Id               ( getIdUniType, Id, isSysLocalId )
  63 import Inst             ( getInstOrigin, getDictClassAndType, Inst )
  64 import Name             ( cmpName )
  65 import Outputable
  66 import Pretty           -- to pretty-print error messages
  67 #ifdef DPH
  68 import PodizeMonad      ( PodWarning(..) )
  69 #endif {- Data Parallel Haskell -}
  70 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  71 import Util
  72 \end{code}
  73
  74 \begin{code}
  75 ambigErr :: [Inst] -> Error
  76 ambigErr insts@(inst1:_)
  77   = addErrLoc loc1 "Ambiguous overloading" ( \ sty ->
  78     ppAboves (map (ppr_inst sty) insts) )
  79   where
  80     (loc1, _) = getInstOrigin inst1
  81
  82 ppr_inst sty inst
  83   = let
  84         (clas, ty)  = getDictClassAndType inst
  85         (locn, msg) = getInstOrigin inst
  86     in
  87     ppSep [ ppBesides [ppStr "class `", ppr sty clas,
  88                        ppStr "', type `", ppr sty ty, ppStr "'"],
  89             ppBesides [ppStr "(", msg sty, ppStr ")"] ]
  90
  91 ----------------------------------------------------------------
  92 badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> Error
  93 badMatchErr sig_ty inferred_ty ctxt locn
  94   = addErrLoc locn "Type signature mismatch" ( \ sty ->
  95     let
  96         thing
  97           = case ctxt of
  98               SigCtxt id _     -> ppBesides [ppChar '`', ppr sty id, ppChar '\'']
  99               MethodSigCtxt op _ -> ppBesides [ppStr "class method `", ppr sty op, ppStr "'"]
 100               ExprSigCtxt _ _  -> ppStr "an expression"
 101               Rank2ArgCtxt _ _ -> ppStr "an expression with rank-2 polymorphic type(!)"
 102               ctxt             -> pprUnifyErrContext sty ctxt
 103                 -- the latter is ugly, but better than a patt-match failure
 104     in
 105     ppAboves [ppSep [
 106                 ppStr "Signature for", thing, ppStr "doesn't match its inferred type."
 107               ],
 108               ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
 109               ppHang (ppStr "Inferred type:") 4 (ppr sty inferred_ty)
 110     ] )
 111
 112 ----------------------------------------------------------------
 113 badSpecialisationErr :: String -> String -> Int -> [Maybe UniType] -> SrcLoc -> Error
 114
 115 badSpecialisationErr flavor messg no_tyvars ty_maybes locn
 116   = addErrLoc locn ("Bad "++flavor++" specialisation pragma: "++messg)  ( \ sty ->
 117     ppStr "MSG NOT DONE YET"
 118     )
 119
 120 ----------------------------------------------------------------
 121 confusedNameErr :: String
 122                 -> Name         -- the confused name
 123                 -> SrcLoc
 124                 -> Error
 125 confusedNameErr msg nm locn
 126   = addErrLoc locn msg ( \ sty ->
 127     ppr sty nm )
 128 {-
 129   where
 130     msg = if flag then "Type constructor used where a class is expected"
 131                   else "Class used where a type constructor is expected"
 132 -}
 133
 134 ----------------------------------------------------------------
 135 typeCycleErr :: [[(Pretty, SrcLoc)]] -> Error
 136 typeCycleErr = cycleErr  "The following type synonyms refer to themselves:"
 137
 138 classCycleErr :: [[(Pretty, SrcLoc)]] -> Error
 139 classCycleErr = cycleErr  "The following classes form a cycle:"
 140
 141 cycleErr :: String -> [[(Pretty, SrcLoc)]] -> Error
 142 cycleErr msg cycles sty
 143  = ppHang (ppStr msg)
 144         4 (ppAboves (map pp_cycle cycles))
 145  where
 146    pp_cycle things      = ppAboves (map pp_thing things)
 147    pp_thing (thing,loc) = ppHang (ppBesides [ppr PprForUser loc, ppStr ": "]) 4 thing
 148
 149 ----------------------------------------------------------------
 150 defaultErr :: [Inst]{-dicts-} -> [UniType] -> Error
 151         -- when default-resolution fails...
 152
 153 defaultErr dicts defaulting_tys sty
 154   = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
 155          4 (ppAboves [
 156              ppHang (ppStr "Conflicting:")
 157                   4 (ppInterleave ppSemi (map (ppr_inst sty) dicts)),
 158              ppHang (ppStr "Defaulting types :")
 159                   4 (ppr sty defaulting_tys),
 160              ppStr "([Int, Double] is the default list of defaulting types.)" ])
 161
 162 ----------------------------------------------------------------
 163 derivingEnumErr :: TyCon -> Error
 164 derivingEnumErr tycon
 165   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
 166     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 167
 168 ----------------------------------------------------------------
 169 derivingIxErr :: TyCon -> Error
 170 derivingIxErr tycon
 171   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
 172     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 173
 174 ----------------------------------------------------------------
 175 derivingWhenInstanceExistsErr :: Class -> TyCon -> Error
 176 derivingWhenInstanceExistsErr clas tycon
 177   = addErrLoc (getSrcLoc tycon) "`deriving' when an instance also exists" ( \ sty ->
 178     ppBesides [ppStr "class `", ppr sty clas,
 179                ppStr "', type `", ppr sty tycon, ppStr "'"] )
 180
 181 ----------------------------------------------------------------
 182 {- UNUSED:
 183 derivingNoSuperClassInstanceErr :: Class -> TyCon -> Class -> Error
 184 derivingNoSuperClassInstanceErr clas tycon super_class
 185   = addErrLoc (getSrcLoc tycon) "No instance for a superclass in a `deriving'" ( \ sty ->
 186     ppSep [ppBesides [ppStr "the superclass `", ppr sty super_class, ppStr "' has no instance"],
 187            ppBesides [ppStr "at the type `", ppr sty tycon, ppStr "';"],
 188            ppBesides [ppStr "(the class being \"derived\" is `", ppr sty clas, ppStr "')"]
 189           ])
 190 -}
 191
 192 ----------------------------------------------------------------
 193 dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
 194 dupInstErr (clas, info1@(ty1, locn1), info2@(ty2, locn2))
 195         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 196   = addErrLoc locn1 "Duplicate/overlapping instances" ( \ sty ->
 197     ppSep [ ppBesides [ppStr "class `", ppr sty clas, ppStr "',"],
 198             showOverlap sty info1 info2] )
 199
 200 ----------------------------------------------------------------
 201 {- UNUSED?
 202 extraMethodsErr :: [Id] {-dicts-} -> SrcLoc -> Error
 203         -- when an instance decl has binds for methods that aren't in the class decl
 204 extraMethodsErr extra_methods locn
 205   = addErrLoc locn "Extra methods in instance declaration" ( \ sty ->
 206     interpp'SP sty extra_methods )
 207 -}
 208
 209 ----------------------------------------------------------------
 210 genCantGenErr :: [Inst] -> Error
 211 genCantGenErr insts@(inst1:_)
 212   = addErrLoc loc1 "Cannot generalise these overloadings (in a _ccall_):" ( \ sty ->
 213     ppAboves (map (ppr_inst sty) insts) )
 214   where
 215     (loc1, _) = getInstOrigin inst1
 216
 217 ----------------------------------------------------------------
 218 {- UNUSED:
 219 genPrimTyVarErr :: [TyVar] -> SrcLoc -> Error
 220         -- Attempt to generalise over a primitive type variable
 221
 222 genPrimTyVarErr tyvars locn
 223   = addErrLoc locn "These primitive type variables can't be made more general" ( \ sty ->
 224         ppAbove (interpp'SP sty tyvars)
 225                 (ppStr "(Solution: add a type signature.)") )
 226 -}
 227 ----------------------------------------------------------------
 228 noInstanceErr :: Inst -> Error
 229 noInstanceErr inst
 230   = let (clas, ty)  = getDictClassAndType inst
 231         (locn, msg) = getInstOrigin inst
 232     in
 233     addErrLoc locn "No such instance" ( \ sty ->
 234     ppSep [ ppBesides [ppStr "class `", ppr sty clas,
 235                        ppStr "', type `", ppr sty ty, ppStr "'"],
 236             ppBesides [ppStr "(", msg sty, ppStr ")"] ]
 237     )
 238
 239 ----------------------------------------------------------------
 240 {- UNUSED:
 241 instOpErr :: Id -> Class -> TyCon -> Error
 242
 243 instOpErr dict clas tycon
 244         -- no instance of "Class" for "TyCon"
 245         -- the Id is the offending dictionary; has src location
 246         -- (and we could get the Class and TyCon from it, but
 247         -- since we already have it at hand ...)
 248   = addErrLoc (getSrcLoc dict) "Invalid instance" ( \ sty ->
 249     ppBesides [ ppStr "There is no instance of `", ppr sty tycon,
 250                 ppStr "' for class `",
 251                 ppr sty clas, ppChar '\'' ] )
 252 -}
 253
 254 ----------------------------------------------------------------
 255 instTypeErr :: UniType -> SrcLoc -> Error
 256 instTypeErr ty locn
 257   = addShortErrLocLine locn (\ sty ->
 258     let
 259         rest_of_msg = ppStr "' cannot be used as the instance type\n    in an instance declaration."
 260     in
 261     case ty of
 262       UniSyn tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
 263       UniTyVar tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
 264       other         -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
 265     )
 266
 267 ----------------------------------------------------------------
 268 {- UNUSED:
 269 methodInstErr :: (ClassOp, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
 270 methodInstErr (class_op, info1, info2) sty
 271         -- Two instances for given class op
 272   = ppHang (ppBesides [ ppStr "The class method `", ppr sty class_op, ppStr "' has been given more than one definition for"])
 273         4 (showOverlap sty info1 info2)
 274 -}
 275
 276 showOverlap :: PprStyle -> (UniType, SrcLoc) -> (UniType, SrcLoc) -> Pretty
 277 showOverlap sty (ty1,loc1) (ty2,loc2)
 278   = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
 279            ppBeside (ppStr "at ") (ppr sty loc1),
 280            ppBeside (ppStr "and ") (ppr sty loc2)]
 281
 282 ----------------------------------------------------------------
 283 methodTypeLacksTyVarErr :: TyVarTemplate -> String -> SrcLoc -> Error
 284 methodTypeLacksTyVarErr tyvar method_name locn
 285   = addErrLoc locn "Method's type doesn't mention the class type variable"  (\ sty ->
 286     ppAboves [ppBeside (ppStr "Class type variable: ") (ppr sty tyvar),
 287               ppBeside (ppStr "Method: ") (ppStr method_name)] )
 288
 289 ----------------------------------------------------------------
 290 {- UNUSED:
 291 missingClassOpErr :: Id -> [ClassOp] -> SrcLoc -> Error
 292 missingClassOpErr op classops locn
 293   = addErrLoc locn "Undefined class method" ( \ sty ->
 294     ppBesides [ ppr sty op, ppStr "; valid method(s):",
 295                 interpp'SP sty classops ] )
 296 -}
 297
 298 ----------------------------------------------------------------
 299 naughtyCCallContextErr :: Name -> SrcLoc -> Error
 300 naughtyCCallContextErr clas_name locn
 301   = addErrLoc locn "Can't use this class in a context" (\ sty ->
 302     ppr sty clas_name )
 303
 304 ----------------------------------------------------------------
 305 nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> Error
 306 nonBoxedPrimCCallErr clas inst_ty locn
 307   = addErrLoc locn "Instance isn't for a `boxed-primitive' type" ( \ sty ->
 308     ppBesides [ ppStr "class `", ppr sty clas, ppStr "'; type `",
 309                 ppr sty inst_ty, ppStr "'"] )
 310
 311 ----------------------------------------------------------------
 312 notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> Error
 313 notAsPolyAsSigErr sig_ty mono_tyvars ctxt locn
 314   = addErrLoc locn "A type signature is more polymorphic than the inferred type" ( \ sty ->
 315     ppAboves [  ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
 316                 pprUnifyErrContext sty ctxt,
 317                 ppHang (ppStr "Monomorphic type variable(s):")
 318                    4 (interpp'SP sty mono_tyvars),
 319                 ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
 320         ] )
 321
 322 ----------------------------------------------------------------
 323 {- UNUSED:
 324 patMatchWithPrimErr :: Error
 325 patMatchWithPrimErr
 326   = dontAddErrLoc
 327         "Pattern-bindings may not involve primitive types." ( \ sty ->
 328         ppNil )
 329 -}
 330
 331 ----------------------------------------------------------------
 332 preludeInstanceErr :: Class -> UniType -> SrcLoc -> Error
 333 preludeInstanceErr clas ty locn
 334   = addShortErrLocLine locn ( \ sty ->
 335     ppHang (ppBesides [ppStr "Illegal instance: for Prelude class `", ppr sty clas,
 336                          ppStr "' and Prelude type `", ppr sty ty, ppStr "'."] )
 337          4 (ppStr "(An instance decl must be in the same module as the type decl or the class decl)") )
 338
 339 ----------------------------------------------------------------
 340 {- UNUSED:
 341 purelyLocalErr :: Name -> SrcLoc -> Error
 342 purelyLocalErr thing locn
 343   = addShortErrLocLine locn ( \ sty ->
 344     ppBesides [ppStr "`", ppr sty thing,
 345                ppStr "' cannot be exported -- it would refer to an unexported local entity."] )
 346 -}
 347
 348 ----------------------------------------------------------------
 349 reduceErr :: [Inst] -> UnifyErrContext -> Error
 350         -- Used by tcSimplifyCheckLIE
 351         -- Could not express required dictionaries in terms of the signature
 352 reduceErr insts ctxt
 353   = dontAddErrLoc "Type signature lacks context required by inferred type" ( \ sty ->
 354     ppAboves [
 355         pprUnifyErrContext sty ctxt,
 356         ppHang (ppStr "Context reqd: ")
 357              4 (ppAboves (map (ppr_inst sty) insts))
 358     ])
 359   where
 360     ppr_inst sty inst
 361       = let (clas, ty)  = getDictClassAndType inst
 362             (locn, msg) = getInstOrigin inst
 363         in
 364         ppSep [ ppBesides [ppr sty locn, ppStr ": ", ppr sty clas, ppSP, ppr sty ty],
 365                 ppBesides [ppStr "(", msg sty, ppStr ")"] ]
 366
 367 ----------------------------------------------------------------
 368 {-
 369 unexpectedPreludeThingErr :: Outputable a => String -> a -> SrcLoc -> Error
 370
 371 unexpectedPreludeThingErr category thing locn
 372   = addShortErrLocLine locn ( \ sty ->
 373     ppBesides [ppStr "Prelude ", ppStr category,
 374                ppStr " not expected here: ", ppr sty thing])
 375 -}
 376
 377 ----------------------------------------------------------------
 378 specGroundnessErr :: UnifyErrContext -> [UniType] -> Error
 379
 380 specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys
 381   = addShortErrLocLine locn ( \ sty ->
 382     ppHang (
 383         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 384                ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"],
 385                ppStr "... not all type variables were instantiated",
 386                ppStr "to type variables or ground types (nothing in between, please!):"])
 387       4 (ppAboves (map (ppr sty) arg_tys))
 388     )
 389
 390 ----------------------------------------------------------------
 391 specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> Error
 392
 393 specCtxtGroundnessErr err_ctxt dicts
 394   = addShortErrLocLine locn ( \ sty ->
 395     ppHang (
 396         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 397                ppBesides [ppStr " specialised to the type `", ppr sty spec_ty,  ppStr "'"],
 398                pp_spec_id sty,
 399                ppStr "... not all overloaded type variables were instantiated",
 400                ppStr "to ground types:"])
 401       4 (ppAboves [ppCat [ppr sty c, ppr sty t]
 402                   | (c,t) <- map getDictClassAndType dicts])
 403     )
 404   where
 405     (name, spec_ty, locn, pp_spec_id)
 406       = case err_ctxt of
 407           ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
 408           ValSpecSpecIdCtxt n ty spec loc ->
 409             (n, ty, loc,
 410              \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
 411
 412 ----------------------------------------------------------------
 413 specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> Error
 414
 415 specDataNoSpecErr name arg_tys locn
 416   = addShortErrLocLine locn ( \ sty ->
 417     ppHang (
 418         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 419                ppStr "... no unboxed type arguments in specialisation:"])
 420      4 (ppAboves (map (ppr sty) arg_tys))
 421     )
 422
 423 ----------------------------------------------------------------
 424 specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> Error
 425
 426 specDataUnboxedErr name arg_tys locn
 427   = addShortErrLocLine locn ( \ sty ->
 428     ppHang (
 429         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 430                ppStr "... not all type arguments were specialised to",
 431                ppStr "specific unboxed types or (boxed) type variables:"])
 432       4 (ppAboves (map (ppr sty) arg_tys))
 433     )
 434
 435 ----------------------------------------------------------------
 436 specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> Error
 437
 438 specInstUnspecInstNotFoundErr clas inst_ty locn
 439   = addErrLoc locn "No local instance to specialise" ( \ sty ->
 440     ppBesides [ ppStr "class `", ppr sty clas, ppStr "' at the type `",
 441                 ppr sty inst_ty, ppStr "'"] )
 442
 443 ----------------------------------------------------------------
 444 -- The type signatures on a mutually-recursive group of definitions
 445 -- must all have the same context (or none).  For example:
 446 --      f :: Eq a => ...
 447 --      g :: (Eq a, Text a) => ...
 448 -- is illegal if f and g are mutually recursive.  This also
 449 -- applies to variables bound in the same pattern binding.
 450
 451 sigContextsErr :: [SignatureInfo] -> Error
 452
 453 sigContextsErr infos
 454   = dontAddErrLoc "A group of type signatures have mismatched contexts" ( \ sty ->
 455     ppAboves (map (ppr_sig_info sty) infos) )
 456   where
 457     ppr_sig_info sty (TySigInfo val tyvars insts tau_ty _)
 458       = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
 459              4 (ppHang (if null insts
 460                         then ppNil
 461                         else ppBesides [ppStr "(", ppInterleave ppComma (map (ppr_inst sty) insts), ppStr ") => "])
 462                      4 (ppr sty tau_ty))
 463
 464     ppr_inst sty inst
 465       = let (clas, ty)  = getDictClassAndType inst
 466             (locn, msg) = getInstOrigin inst
 467         in
 468         ppCat [ppr sty clas, ppr sty ty]
 469
 470 ----------------------------------------------------------------
 471 topLevelUnboxedDeclErr :: Id -> SrcLoc -> Error
 472         -- Top level decl of something with a primitive type
 473
 474 topLevelUnboxedDeclErr id locn
 475   = addShortErrLocLine locn ( \ sty ->
 476         ppBesides [ppStr "The top-level value `", ppr sty id, ppStr "' shouldn't have an unboxed type." ])
 477
 478 ----------------------------------------------------------------
 479 dataConArityErr :: Id   -> Int -> Int -> SrcLoc -> Error
 480 tyConArityErr   :: Name -> Int -> Int -> SrcLoc -> Error
 481
 482 tyConArityErr   = arityError "Type"
 483 dataConArityErr = arityError "Constructor"
 484
 485 arityError kind name n m locn =
 486     addErrLoc locn errmsg
 487     (\ sty ->
 488     ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
 489                 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'])
 490     where
 491         errmsg = kind ++ " has too " ++ quantity ++ " arguments"
 492         quantity | m < n     = "few"
 493                  | otherwise = "many"
 494         n_arguments | n == 0 = ppStr "no arguments"
 495                     | n == 1 = ppStr "1 argument"
 496                     | True   = ppCat [ppInt n, ppStr "arguments"]
 497
 498 ----------------------------------------------------------------
 499 unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error
 500
 501 unifyErr unify_err_info unify_err_context locn
 502   = addShortErrLocLine locn ( \ sty ->
 503     pprUnifyErrInfo sty unify_err_info unify_err_context)
 504
 505 ----------------------------------------------------------------
 506 varyingArgsErr :: Name -> [RenamedMatch] -> Error
 507         -- Different number of arguments in different equations
 508
 509 varyingArgsErr name matches
 510   = dontAddErrLoc "Varying number of arguments for function" ( \ sty ->
 511     ppr sty name )
 512 {-
 513 varyingArgsErr name matches
 514   = addErrLoc locn "Function Definition Error" ( \ sty ->
 515         ppBesides [ppStr "Function `", ppr sty name, ppStr "' should have a fixed number of arguments" ])
 516 -}
 517 \end{code}
 518
 519 %************************************************************************
 520 %*                                                                      *
 521 \subsection[UnifyErr-types]{@UnifyErrInfo@ and @UnifyErrContext@ datatypes}
 522 %*                                                                      *
 523 %************************************************************************
 524
 525 Here are the things that can go wrong during unification:
 526
 527 \begin{code}
 528 data UnifyErrInfo
 529   = UnifyMisMatch       UniType UniType
 530   | TypeRec             TyVar   TauType -- Occurs check failure
 531
 532   | UnifyListMisMatch   [TauType] [TauType]   -- Args to unifyList: diff lengths
 533                                               -- produces system error
 534 \end{code}
 535
 536 @UnifyErrContext@ gives some context for unification
 537 errors found in expressions.  Also see the @UnifyErrInfo@ type (above),
 538 as well as the general error-reporting type @Error@ (in @TcErrors@).
 539 \begin{code}
 540 data UnifyErrContext
 541   = PredCtxt            RenamedExpr
 542   | AppCtxt             RenamedExpr RenamedExpr
 543
 544   | TooManyArgsCtxt     RenamedExpr     -- The offending function
 545                                         -- We don't want the typechecked expr here,
 546                                         -- because that may be full of
 547                                         -- confusing dictionaries
 548
 549   | FunAppCtxt          RenamedExpr     -- The offending function
 550                         (Maybe Id)      -- same info (probably) in a more convenient form
 551                         RenamedExpr     -- The offending arg
 552                         UniType         -- Expected type of offending arg
 553                         UniType         -- Inferred type for offending arg
 554                         Int             -- Which arg number (first is 1)
 555
 556   | OpAppCtxt           RenamedExpr RenamedExpr RenamedExpr
 557   | SectionLAppCtxt     RenamedExpr RenamedExpr
 558   | SectionRAppCtxt     RenamedExpr RenamedExpr
 559   | CaseCtxt            RenamedExpr [RenamedMatch]
 560   | BranchCtxt          RenamedExpr RenamedExpr
 561   | ListCtxt            [RenamedExpr]
 562   | PatCtxt             RenamedPat
 563   | CaseBranchesCtxt    [RenamedMatch]
 564   | FilterCtxt          RenamedExpr
 565   | GeneratorCtxt       RenamedPat RenamedExpr
 566   | GRHSsBranchCtxt     [RenamedGRHS]
 567   | GRHSsGuardCtxt      RenamedExpr
 568   | PatMonoBindsCtxt    RenamedPat RenamedGRHSsAndBinds
 569   | FunMonoBindsCtxt    Name [RenamedMatch]
 570   | MatchCtxt           UniType UniType
 571   | ArithSeqCtxt        RenamedExpr
 572   | CCallCtxt           String [RenamedExpr]
 573   | AmbigDictCtxt       [Inst]  -- Occurs check when simplifying ambiguous
 574                                 -- dictionaries.  Should never happen!
 575   | SigCtxt             Id UniType
 576   | MethodSigCtxt       Name UniType
 577   | ExprSigCtxt         RenamedExpr UniType
 578   | ValSpecSigCtxt      Name UniType SrcLoc
 579   | ValSpecSpecIdCtxt   Name UniType Name SrcLoc
 580
 581         -- The next two contexts are associated only with TcSimplifyAndCheck failures
 582   | BindSigCtxt         [Id]            -- Signature(s) for a group of bindings
 583   | SuperClassSigCtxt                   -- Superclasses for this instance decl
 584
 585   | CaseBranchCtxt      RenamedMatch
 586   | Rank2ArgCtxt        TypecheckedExpr UniType
 587 #ifdef DPH
 588   | PodCtxt             [RenamedExpr]
 589   | ParFilterCtxt       RenamedExpr
 590   | DrawnCtxt           [RenamedPat]  RenamedPat RenamedExpr
 591   | IndexCtxt           [RenamedExpr] RenamedPat RenamedExpr
 592   | ParPidPatCtxt       RenamedPat
 593   | ParPidExpCtxt       RenamedExpr
 594   | ParZFlhsCtxt        RenamedExpr
 595 #endif {- Data Parallel Haskell -}
 596 \end{code}
 597
 598 %************************************************************************
 599 %*                                                                      *
 600 \subsection[Errors-print-unify]{Printing unification error info}
 601 %*                                                                      *
 602 %************************************************************************
 603
 604 \begin{code}
 605 ppUnifyErr :: Pretty -> Pretty -> Pretty
 606 ppUnifyErr head rest = ppSep [head, {-if you want a blank line: ppSP,-} rest]
 607
 608 pprUnifyErrInfo sty (UnifyMisMatch mt1 mt2) err_ctxt
 609  = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type `", ppr sty mt1, ppStr "'"],
 610                       ppBesides [ppStr "against `", ppr sty mt2, ppStr "'."]])
 611               (pprUnifyErrContext sty err_ctxt)
 612
 613 pprUnifyErrInfo sty (TypeRec tyvar ty) err_ctxt
 614  = ppUnifyErr (ppBesides [ppStr "Cannot construct the infinite type `",
 615                                  ppr sty tyvar,
 616                                  ppStr "' = `",ppr sty ty, ppStr "' (\"occurs check\")."])
 617               (pprUnifyErrContext sty err_ctxt)
 618
 619 pprUnifyErrInfo sty (UnifyListMisMatch tys1 tys2) err_ctxt
 620  = panic "pprUnifyErrInfo: unifying lists of types of different lengths"
 621 \end{code}
 622
 623 %************************************************************************
 624 %*                                                                      *
 625 \subsection[Errors-print-context]{Printing unification error context}
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 pp_nest_hang :: String -> Pretty -> Pretty
 631 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 632
 633 context = "Error detected when type-checking "
 634
 635 ppContext s = ppStr (context ++ s)
 636
 637 pprUnifyErrContext sty (PredCtxt e)
 638   = ppHang (ppStr "In a predicate expression:") 4 (ppr sty e)
 639
 640 pprUnifyErrContext sty (AppCtxt f a)
 641   = ppHang (ppStr "In a function application:") 4 (ppr sty (App f a))
 642
 643 pprUnifyErrContext sty (FunAppCtxt f maybe_id actual_arg expected_arg_ty actual_arg_ty n)
 644   = let
 645
 646         (have_extra_info, f_id, f_type)
 647            = case maybe_id of
 648                Nothing -> (False, bottom, bottom)
 649                Just id -> (True,  id, getIdUniType id)
 650
 651         free_tyvars = extractTyVarsFromTy f_type
 652         bottom = panic "no maybe_id"
 653     in
 654     ppAboves [
 655         ppHang (ppCat [ ppStr "In the", speakNth n, ppStr "argument of",
 656                         ppBesides [ppChar '`', ppr sty f, ppStr "',"] ])
 657         4 (ppBesides [ppStr " namely `", ppr sty actual_arg, ppStr "'," ]),
 658
 659         ppHang  (ppStr "Expected type of the argument: ")
 660                 4 (ppr sty expected_arg_ty),
 661
 662         ppHang  (ppStr "Inferred type of the argument: ")
 663                 4 (ppr sty actual_arg_ty),
 664
 665 {- OMIT
 666    I'm not sure this adds anything
 667
 668         if have_extra_info
 669         then ppHang (ppCat [ppStr "The type of",
 670                             ppBesides [ppChar '`', ppr sty f_id, ppChar '\''],
 671                             ppStr "is"]) 4
 672                     (ppBesides [ppChar '`', ppr sty f_type, ppStr "'."])
 673         else ppNil,
 674 -}
 675
 676         if not have_extra_info || null free_tyvars || isSysLocalId f_id
 677                 -- SysLocals are created for the local (monomorphic) versions
 678                 -- of recursive functions, and the monomorphism suggestion
 679                 -- below is sometimes positively misleading.  Notably,
 680                 -- if you give an erroneous type sig, you may well end
 681                 -- up with a unification error like this, and it usually ain't due
 682                 -- to monomorphism.
 683         then ppNil
 684         else
 685            ppAboves [
 686                 ppSep [ppStr "Possible cause of error:",
 687                        ppBesides [ppChar '`', ppr sty f, ppChar '\''],
 688                        ppStr "is not polymorphic"],
 689                 ppSep [ppStr "it is monomorphic in the type variable(s):",
 690                        interpp'SP sty free_tyvars]
 691            ]
 692     ]
 693
 694 pprUnifyErrContext sty (TooManyArgsCtxt f)
 695   = ppHang (ppStr "Too many arguments in an application of the function")
 696          4 (ppBesides [ ppChar '`', ppr sty f, ppStr "'." ])
 697
 698 pprUnifyErrContext sty (SectionLAppCtxt expr op)
 699   = ppHang (ppStr "In a left section:")  4 (ppr sty (SectionL expr op))
 700
 701 pprUnifyErrContext sty (SectionRAppCtxt op expr)
 702   = ppHang (ppStr "In a right section:") 4 (ppr sty (SectionR op expr))
 703
 704 pprUnifyErrContext sty (OpAppCtxt a1 op a2)
 705   = ppHang (ppStr "In an infix-operator application:") 4 (ppr sty (OpApp a1 op a2))
 706
 707 pprUnifyErrContext sty (CaseCtxt e as)
 708   = ppHang (ppStr "In a case expression:") 4 (ppr sty (Case e as))
 709
 710 pprUnifyErrContext sty (BranchCtxt b1 b2)
 711   = ppSep [ppStr "In the branches of a conditional:",
 712            pp_nest_hang "`then' branch:" (ppr sty b1),
 713            pp_nest_hang "`else' branch:" (ppr sty b2)]
 714
 715 pprUnifyErrContext sty (ListCtxt es)
 716   = ppHang (ppStr "In a list expression:") 4 (
 717               ppBesides [ppLbrack, interpp'SP sty es, ppRbrack])
 718
 719 pprUnifyErrContext sty (PatCtxt (ConPatIn name pats))
 720   = ppHang (ppStr "In a constructed pattern:")
 721          4 (ppCat [ppr sty name, interppSP sty pats])
 722
 723 pprUnifyErrContext sty (PatCtxt (ConOpPatIn pat1 op pat2))
 724   = ppHang (ppStr "In an infix-operator pattern:")
 725          4 (ppCat [ppr sty pat1, ppr sty op, ppr sty pat2])
 726
 727 pprUnifyErrContext sty (PatCtxt (ListPatIn ps))
 728   = ppHang (ppStr "In an explicit list pattern:")
 729          4 (ppBesides [ppLbrack, interpp'SP sty ps, ppRbrack])
 730
 731 pprUnifyErrContext sty (PatCtxt pat@(AsPatIn _ _))
 732   = ppHang (ppStr "In an as-pattern:") 4 (ppr sty pat)
 733
 734 pprUnifyErrContext sty (CaseBranchesCtxt (m:ms))
 735   = ppAboves [ppStr "Inside two case alternatives:",
 736               ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) [m])),
 737               ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) ms))]
 738
 739 pprUnifyErrContext sty (FilterCtxt e)
 740   = ppHang (ppStr "In a guard in a list-comprehension:") 4 (ppr sty e)
 741
 742 pprUnifyErrContext sty (GeneratorCtxt p e)
 743   = ppHang (ppStr "In a generator in a list-comprehension:")
 744          4 (ppSep [ppr sty p, ppStr "<-", ppr sty e])
 745
 746 pprUnifyErrContext sty (GRHSsBranchCtxt grhss)
 747   = ppAboves [ppStr "In some guarded right-hand-sides:",
 748               ppNest 4 (ppAboves (map (pprGRHS sty False) grhss))]
 749
 750 pprUnifyErrContext sty (GRHSsGuardCtxt g)
 751   = ppHang (ppStr "In a guard on an equation:") 4 (ppr sty g)
 752
 753 pprUnifyErrContext sty (PatMonoBindsCtxt pat grhss_and_binds)
 754   = ppHang (ppStr "In a pattern binding:")
 755          4 (ppr sty (PatMonoBind pat grhss_and_binds mkUnknownSrcLoc))
 756
 757 pprUnifyErrContext sty (FunMonoBindsCtxt id matches)
 758   = ppHang (ppStr "When combining a function's equation(s) & type signature (if applicable):")
 759          4 (ppBesides [ppr sty id, ppSP, pprMatches sty (False,ppNil) matches])
 760
 761 pprUnifyErrContext sty (CaseBranchCtxt match)
 762   = ppHang (ppStr "When combining a \"case\" branch & type signature (if applicable):")
 763          4 (pprMatch sty True{-is_case-} match)
 764
 765 pprUnifyErrContext sty (MatchCtxt ty1 ty2)
 766   = ppAboves [ppStr "In a type signature:",
 767               pp_nest_hang "Signature:" (ppr sty ty1),
 768               pp_nest_hang "Inferred type:" (ppr sty ty2)]
 769
 770 pprUnifyErrContext sty (ArithSeqCtxt expr)
 771   = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
 772
 773 pprUnifyErrContext sty (CCallCtxt label args)
 774   = ppAboves [ppStr "In a _ccall_ or _casm_:",
 775               pp_nest_hang "C-calling magic:" (ppStr label),
 776               pp_nest_hang "Arguments:" (ppInterleave ppComma (map (ppr sty) args))]
 777
 778 -- OLD: kill
 779 pprUnifyErrContext sty (AmbigDictCtxt dicts)
 780   = ppStr "Ambiguous dictionary occurs check: should never happen!"
 781
 782 pprUnifyErrContext sty (SigCtxt id tau_ty)
 783   = ppHang (ppBesides [ppStr "In the type signature for ",
 784                    ppr sty id,
 785                    ppStr ":"]
 786            ) 4 (ppr sty tau_ty)
 787
 788 pprUnifyErrContext sty (MethodSigCtxt name ty)
 789   = ppHang (ppBesides [ ppStr "When matching the definition of class method `",
 790                 ppr sty name, ppStr "' to its signature :" ]
 791            ) 4 (ppr sty ty)
 792
 793 pprUnifyErrContext sty (ExprSigCtxt expr ty)
 794   = ppHang (ppStr "In an expression with a type signature:")
 795          4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
 796                   ppr sty ty])
 797
 798 pprUnifyErrContext sty (BindSigCtxt ids)
 799   = ppHang (ppStr "When checking type signatures for: ")
 800          4 (ppInterleave (ppStr ", ") (map (ppr sty) ids))
 801
 802 pprUnifyErrContext sty SuperClassSigCtxt
 803   = ppStr "When checking superclass constraints on instance declaration"
 804
 805 pprUnifyErrContext sty (Rank2ArgCtxt expr ty)
 806   = ppHang (ppStr "In an argument which has rank-2 polymorphic type:")
 807          4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
 808                   ppr sty ty])
 809
 810 pprUnifyErrContext sty (ValSpecSigCtxt v ty src_loc)
 811   = ppHang (ppStr "In a SPECIALIZE pragma for a value:")
 812          4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
 813                   ppr sty ty])
 814
 815 pprUnifyErrContext sty (ValSpecSpecIdCtxt v ty spec src_loc)
 816   = ppHang (ppStr "When checking type of explicit id in SPECIALIZE pragma:")
 817          4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
 818                   ppr sty ty,
 819                   ppBeside (ppStr " = ") (ppr sty spec)])
 820
 821 #ifdef DPH
 822 pprUnifyErrContext sty (PodCtxt es)
 823   = ppAboves [ppStr "In a POD expression:",
 824               ppBesides [ppStr "<<", interpp'SP sty es, ppStr ">>"]]
 825
 826 pprUnifyErrContext sty (ParFilterCtxt e)
 827   = ppHang (ppStr "In a guard of a POD comprehension:") 4
 828            (ppr sty e)
 829
 830 pprUnifyErrContext sty (DrawnCtxt ps p e)
 831   = ppHang (ppStr "In parallel drawn from generator:")
 832            4 (ppSep [ppStr "(|" ,interpp'SP sty ps, ppStr ";" ,
 833                      ppr sty p ,ppStr "|)", ppStr "<<-", ppr sty e])
 834
 835 pprUnifyErrContext sty (IndexCtxt es p e)
 836   = ppHang (ppStr "In parallel index from generator:")
 837            4 (ppSep [ppStr "(|",interpp'SP sty es, ppStr ";" ,
 838                      ppr sty p ,ppStr "|)" , ppStr "<<=", ppr sty e])
 839
 840 pprUnifyErrContext sty (ParPidPatCtxt p)
 841   = ppHang (ppStr "In pattern for processor ID has to be in class Pid:")
 842            4 (ppr sty p)
 843
 844 pprUnifyErrContext sty (ParPidExpCtxt e)
 845   = ppHang (ppStr "In expression for processor ID has to be in class Pid:")
 846            4 (ppr sty e)
 847
 848 pprUnifyErrContext sty (ParZFlhsCtxt e)
 849   = ppHang (ppStr "In LHS of a POD comprehension has to be in class Processor")
 850            4 (ppr sty e)
 851
 852 #endif {- Data Parallel Haskell -}
 853 \end{code}
 854
 855 \begin{code}
 856 #ifdef DPH
 857 pprPodizedWarning :: PodWarning -> Error
 858 pprPodizedWarning (EntryNotPodized b)
 859    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 860      ppBeside (ppStr "Unable to parallelise entry: ")
 861               (ppr sty b)
 862      )
 863
 864 pprPodizedWarning (NoGoNestedPodized b)
 865    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 866      ppBeside (ppStr "Sorry no nested parallelism yet: ")
 867               (ppr sty b)
 868    )
 869
 870 pprPodizedWarning (ContextNotAvailable b c)
 871    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 872      ppAbove (ppBesides [ppStr "No parallelisation of binding for a ",
 873                          ppStr (show_context c) , ppStr ": ",ppr sty b])
 874              (ppBesides [ppStr "Maybe you should re-compile this module ",
 875                          ppStr "with the `",ppStr (which_flag c),
 876                          ppStr "' flag."])
 877      )
 878
 879 pprPodizedWarning (ImportNotAvailable b c)
 880    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 881      ppAboves [ppBesides [ppStr "No parallelisation of binding for a ",
 882                           ppStr (show_context c),ppStr ": ", ppr sty b],
 883                ppBesides [ppStr "If you re-compile the module `",
 884                           ppStr (fst (getOrigName b)), ppStr "`"],
 885                ppBesides [ppStr "with the `",ppStr (which_flag c),
 886                           ppStr "' flag I may do a better job :-)"]]
 887      )
 888
 889
 890 pprPodizedWarning (ArgsInDifferentContexts b)
 891    = addWarningLoc (getSrcLoc b)                                (\ sty ->
 892      ppBesides [ppStr "Higher Order argument used in different ",
 893                 ppStr "parallel contexts : ",ppr sty b]
 894      )
 895
 896 pprPodizedWarning (NoPodization)
 897    = addWarning                                                 (\ sty ->
 898      ppStr "Program not podized")
 899
 900 pprPodizedWarning (PodizeStats ci pi vl pl)
 901    = addWarning                                                 (\ sty ->
 902      (ppHang (ppStr "Podization Statistics:")
 903              5
 904              (ppAboves [ppCat [ppStr "Info collecting passes =",ppr sty ci],
 905                         ppCat [ppStr "Podization passes      =",ppr sty pi],
 906                         ppCat [ppStr "Vanilla's deleted      =",ppr sty vl],
 907                         ppCat [ppStr "Podized   deleted      =",ppr sty pl]]))
 908      )
 909
 910 show_context :: Int -> String
 911 show_context 1 = "\"vector\""
 912 show_context 2 = "\"matrix\""
 913 show_context 3 = "\"cube\""
 914 show_context n = "\""++(show n)++"-D Pod\""
 915
 916 which_flag :: Int -> String
 917 which_flag 1 = "-fpodize-vector"
 918 which_flag 2 = "-fpodize-matrix"
 919 which_flag 3 = "-fpodize-cube"
 920 #endif {- Data Parallel Haskell -}
 921 \end{code}
 922
 923
 924 @speakNth@ converts an integer to a verbal index; eg 1 maps to ``first'' etc.
 925 \begin{code}
 926 speakNth :: Int -> Pretty
 927 speakNth 1 = ppStr "first"
 928 speakNth 2 = ppStr "second"
 929 speakNth 3 = ppStr "third"
 930 speakNth 4 = ppStr "fourth"
 931 speakNth 5 = ppStr "fifth"
 932 speakNth 6 = ppStr "sixth"
 933 speakNth n = ppBesides [ ppInt n, ppStr "th" ]          -- Wrong for eg "31th"
 934                                                         -- but who cares?
 935 \end{code}