ghc/compiler/coreSyn/CoreLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
   5
   6 \begin{code}
   7 module CoreLint (
   8         lintCoreBindings,
   9         lintUnfolding,
  10         showPass, endPass
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import IO               ( hPutStr, hPutStrLn, stdout )
  16
  17 import CoreSyn
  18 import CoreFVs          ( idFreeVars )
  19 import CoreUtils        ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
  20
  21 import Bag
  22 import Literal          ( literalType )
  23 import DataCon          ( dataConRepType )
  24 import Var              ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
  25 import VarSet
  26 import Subst            ( substTyWith )
  27 import Name             ( getSrcLoc )
  28 import PprCore
  29 import ErrUtils         ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
  30                           ErrMsg, addErrLocHdrLine, pprBagOfErrors,
  31                           WarnMsg, pprBagOfWarnings)
  32 import SrcLoc           ( SrcLoc, noSrcLoc )
  33 import Type             ( Type, tyVarsOfType, eqType,
  34                           splitFunTy_maybe, mkTyVarTy,
  35                           splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
  36                           isUnLiftedType, typeKind,
  37                           isUnboxedTupleType,
  38                           hasMoreBoxityInfo
  39                         )
  40 import TyCon            ( isPrimTyCon )
  41 import BasicTypes       ( RecFlag(..), isNonRec )
  42 import CmdLineOpts
  43 import Maybe
  44 import Outputable
  45
  46 infixr 9 `thenL`, `seqL`
  47 \end{code}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{End pass}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
  56 place for them.  They print out stuff before and after core passes,
  57 and do Core Lint when necessary.
  58
  59 \begin{code}
  60 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
  61 endPass dflags pass_name dump_flag binds
  62   = do
  63         -- Report result size if required
  64         -- This has the side effect of forcing the intermediate to be evaluated
  65         if verbosity dflags >= 2 then
  66            hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
  67          else
  68            return ()
  69
  70         -- Report verbosely, if required
  71         dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
  72
  73         -- Type check
  74         lintCoreBindings dflags pass_name binds
  75
  76         return binds
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 Checks that a set of core bindings is well-formed.  The PprStyle and String
  87 just control what we print in the event of an error.  The Bool value
  88 indicates whether we have done any specialisation yet (in which case we do
  89 some extra checks).
  90
  91 We check for
  92         (a) type errors
  93         (b) Out-of-scope type variables
  94         (c) Out-of-scope local variables
  95         (d) Ill-kinded types
  96
  97 If we have done specialisation the we check that there are
  98         (a) No top-level bindings of primitive (unboxed type)
  99
 100 Outstanding issues:
 101
 102     --
 103     -- Things are *not* OK if:
 104     --
 105     -- * Unsaturated type app before specialisation has been done;
 106     --
 107     -- * Oversaturated type app after specialisation (eta reduction
 108     --   may well be happening...);
 109
 110 \begin{code}
 111 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 112
 113 lintCoreBindings dflags whoDunnit binds
 114   | not (dopt Opt_DoCoreLinting dflags)
 115   = return ()
 116
 117 lintCoreBindings dflags whoDunnit binds
 118   = case (initL (lint_binds binds)) of
 119       (Nothing, Nothing)       -> done_lint
 120
 121       (Nothing, Just warnings) -> printDump (warn warnings) >>
 122                                   done_lint
 123
 124       (Just bad_news, warns)   -> printDump (display bad_news warns)    >>
 125                                   ghcExit 1
 126   where
 127         -- Put all the top-level binders in scope at the start
 128         -- This is because transformation rules can bring something
 129         -- into use 'unexpectedly'
 130     lint_binds binds = addInScopeVars (bindersOfBinds binds) $
 131                        mapL lint_bind binds
 132
 133     lint_bind (Rec prs)         = mapL (lintSingleBinding Recursive) prs        `seqL`
 134                                   returnL ()
 135     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 136
 137     done_lint = doIfSet (verbosity dflags >= 2)
 138                         (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
 139     warn warnings
 140       = vcat [
 141                 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
 142                 warnings,
 143                 offender
 144         ]
 145
 146     display bad_news warns
 147       = vcat [
 148                 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 149                 bad_news,
 150                 maybe offender warn warns  -- either offender or warnings (with offender)
 151         ]
 152
 153     offender
 154       = vcat [
 155                 ptext SLIT("*** Offending Program ***"),
 156                 pprCoreBindings binds,
 157                 ptext SLIT("*** End of Offense ***")
 158         ]
 159 \end{code}
 160
 161 %************************************************************************
 162 %*                                                                      *
 163 \subsection[lintUnfolding]{lintUnfolding}
 164 %*                                                                      *
 165 %************************************************************************
 166
 167 We use this to check all unfoldings that come in from interfaces
 168 (it is very painful to catch errors otherwise):
 169
 170 \begin{code}
 171 lintUnfolding :: DynFlags
 172               -> SrcLoc
 173               -> [Var]          -- Treat these as in scope
 174               -> CoreExpr
 175               -> (Maybe Message, Maybe Message)         -- (Nothing,_) => OK
 176
 177 lintUnfolding dflags locn vars expr
 178   | not (dopt Opt_DoCoreLinting dflags)
 179   = (Nothing, Nothing)
 180
 181   | otherwise
 182   = initL (addLoc (ImportedUnfolding locn) $
 183            addInScopeVars vars             $
 184            lintCoreExpr expr)
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection[lintCoreBinding]{lintCoreBinding}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 Check a core binding, returning the list of variables bound.
 194
 195 \begin{code}
 196 lintSingleBinding rec_flag (binder,rhs)
 197   = addLoc (RhsOf binder) $
 198
 199         -- Check the rhs
 200     lintCoreExpr rhs                            `thenL` \ ty ->
 201
 202         -- Check match to RHS type
 203     lintBinder binder                           `seqL`
 204     checkTys binder_ty ty (mkRhsMsg binder ty)  `seqL`
 205
 206         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 207     checkL (not (isUnLiftedType binder_ty)
 208             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 209            (mkRhsPrimMsg binder rhs)            `seqL`
 210
 211         -- Check whether binder's specialisations contain any out-of-scope variables
 212     mapL (checkBndrIdInScope binder) bndr_vars  `seqL`
 213     returnL ()
 214
 215         -- We should check the unfolding, if any, but this is tricky because
 216         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 217   where
 218     binder_ty = idType binder
 219     bndr_vars = varSetElems (idFreeVars binder)
 220 \end{code}
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection[lintCoreExpr]{lintCoreExpr}
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 \begin{code}
 229 lintCoreExpr :: CoreExpr -> LintM Type
 230
 231 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
 232 lintCoreExpr (Lit lit) = returnL (literalType lit)
 233
 234 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 235   = lintCoreExpr expr   `thenL` \ expr_ty ->
 236     lintTy to_ty        `seqL`
 237     lintTy from_ty      `seqL`
 238     checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)      `seqL`
 239     returnL to_ty
 240
 241 lintCoreExpr (Note other_note expr)
 242   = lintCoreExpr expr
 243
 244 lintCoreExpr (Let (NonRec bndr rhs) body)
 245   = lintSingleBinding NonRecursive (bndr,rhs)   `seqL`
 246     addLoc (BodyOfLetRec [bndr])
 247            (addInScopeVars [bndr] (lintCoreExpr body))
 248
 249 lintCoreExpr (Let (Rec pairs) body)
 250   = addInScopeVars bndrs        $
 251     mapL (lintSingleBinding Recursive) pairs    `seqL`
 252     addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
 253   where
 254     bndrs = map fst pairs
 255
 256 lintCoreExpr e@(App fun arg)
 257   = lintCoreExpr fun    `thenL` \ ty ->
 258     addLoc (AnExpr e)   $
 259     lintCoreArg ty arg
 260
 261 lintCoreExpr (Lam var expr)
 262   = addLoc (LambdaBodyOf var)   $
 263     (if isId var then
 264        checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
 265      else
 266        returnL ())
 267                                 `seqL`
 268     (addInScopeVars [var]       $
 269      lintCoreExpr expr          `thenL` \ ty ->
 270
 271      returnL (mkPiType var ty))
 272
 273 lintCoreExpr e@(Case scrut var alts)
 274  =      -- Check the scrutinee
 275    lintCoreExpr scrut                   `thenL` \ scrut_ty ->
 276
 277         -- Check the binder
 278    lintBinder var                                               `seqL`
 279
 280         -- If this is an unboxed tuple case, then the binder must be dead
 281    {-
 282    checkL (if isUnboxedTupleType (idType var)
 283                 then isDeadBinder var
 284                 else True) (mkUnboxedTupleMsg var)              `seqL`
 285    -}
 286
 287    checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty)     `seqL`
 288
 289    addInScopeVars [var]                         (
 290
 291         -- Check the alternatives
 292    checkCaseAlts e scrut_ty alts                `seqL`
 293
 294    mapL (lintCoreAlt scrut_ty) alts             `thenL` \ (alt_ty : alt_tys) ->
 295    mapL (check alt_ty) alt_tys                  `seqL`
 296    returnL alt_ty)
 297  where
 298    check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
 299
 300 lintCoreExpr e@(Type ty)
 301   = addErrL (mkStrangeTyMsg e)
 302 \end{code}
 303
 304 %************************************************************************
 305 %*                                                                      *
 306 \subsection[lintCoreArgs]{lintCoreArgs}
 307 %*                                                                      *
 308 %************************************************************************
 309
 310 The basic version of these functions checks that the argument is a
 311 subtype of the required type, as one would expect.
 312
 313 \begin{code}
 314 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
 315 lintCoreArgs = lintCoreArgs0 checkTys
 316
 317 lintCoreArg :: Type -> CoreArg -> LintM Type
 318 lintCoreArg = lintCoreArg0 checkTys
 319 \end{code}
 320
 321 The primitive version of these functions takes a check argument,
 322 allowing a different comparison.
 323
 324 \begin{code}
 325 lintCoreArgs0 check_tys ty [] = returnL ty
 326 lintCoreArgs0 check_tys ty (a : args)
 327   = lintCoreArg0  check_tys ty a        `thenL` \ res ->
 328     lintCoreArgs0 check_tys res args
 329
 330 lintCoreArg0 check_tys ty a@(Type arg_ty)
 331   = lintTy arg_ty                       `seqL`
 332     lintTyApp ty arg_ty
 333
 334 lintCoreArg0 check_tys fun_ty arg
 335   = -- Make sure function type matches argument
 336     lintCoreExpr arg            `thenL` \ arg_ty ->
 337     let
 338       err = mkAppMsg fun_ty arg_ty
 339     in
 340     case splitFunTy_maybe fun_ty of
 341       Just (arg,res) -> check_tys arg arg_ty err `seqL`
 342                         returnL res
 343       _              -> addErrL err
 344 \end{code}
 345
 346 \begin{code}
 347 lintTyApp ty arg_ty
 348   = case splitForAllTy_maybe ty of
 349       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 350
 351       Just (tyvar,body) ->
 352         if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
 353         let
 354             tyvar_kind = tyVarKind tyvar
 355             argty_kind = typeKind arg_ty
 356         in
 357         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 358                 -- Arg type might be boxed for a function with an uncommitted
 359                 -- tyvar; notably this is used so that we can give
 360                 --      error :: forall a:*. String -> a
 361                 -- and then apply it to both boxed and unboxed types.
 362          then
 363             returnL (substTyWith [tyvar] [arg_ty] body)
 364         else
 365             addErrL (mkKindErrMsg tyvar arg_ty)
 366
 367 lintTyApps fun_ty []
 368   = returnL fun_ty
 369
 370 lintTyApps fun_ty (arg_ty : arg_tys)
 371   = lintTyApp fun_ty arg_ty             `thenL` \ fun_ty' ->
 372     lintTyApps fun_ty' arg_tys
 373 \end{code}
 374
 375
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection[lintCoreAlts]{lintCoreAlts}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
 385 -- a) Check that the alts are non-empty
 386 -- b) Check that the DEFAULT comes first, if it exists
 387 -- c) Check that there's a default for infinite types
 388 -- NB: Algebraic cases are not necessarily exhaustive, because
 389 --     the simplifer correctly eliminates case that can't
 390 --     possibly match.
 391
 392 checkCaseAlts e ty []
 393   = addErrL (mkNullAltsMsg e)
 394
 395 checkCaseAlts e ty alts
 396   = checkL (all non_deflt con_alts) (mkNonDefltMsg e)   `seqL`
 397     checkL (isJust maybe_deflt || not is_infinite_ty)
 398            (nonExhaustiveAltsMsg e)
 399   where
 400     (con_alts, maybe_deflt) = findDefault alts
 401
 402     non_deflt (DEFAULT, _, _) = False
 403     non_deflt alt             = True
 404
 405     is_infinite_ty = case splitTyConApp_maybe ty of
 406                         Nothing                     -> False
 407                         Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
 408 \end{code}
 409
 410 \begin{code}
 411 lintCoreAlt :: Type                     -- Type of scrutinee
 412             -> CoreAlt
 413             -> LintM Type               -- Type of alternatives
 414
 415 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
 416   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 417     lintCoreExpr rhs
 418
 419 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
 420   = checkL (null args) (mkDefaultArgsMsg args)  `seqL`
 421     checkTys lit_ty scrut_ty
 422              (mkBadPatMsg lit_ty scrut_ty)      `seqL`
 423     lintCoreExpr rhs
 424   where
 425     lit_ty = literalType lit
 426
 427 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
 428   = addLoc (CaseAlt alt) (
 429
 430     mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
 431                         (mkUnboxedTupleMsg arg)) args `seqL`
 432
 433     addInScopeVars args (
 434
 435         -- Check the pattern
 436         -- Scrutinee type must be a tycon applicn; checked by caller
 437         -- This code is remarkably compact considering what it does!
 438         -- NB: args must be in scope here so that the lintCoreArgs line works.
 439         -- NB: relies on existential type args coming *after* ordinary type args
 440     case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
 441         lintTyApps (dataConRepType con) tycon_arg_tys   `thenL` \ con_type ->
 442         lintCoreArgs con_type (map mk_arg args)         `thenL` \ con_result_ty ->
 443         checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 444     }                                           `seqL`
 445
 446         -- Check the RHS
 447     lintCoreExpr rhs
 448     ))
 449   where
 450     mk_arg b | isTyVar b = Type (mkTyVarTy b)
 451              | isId    b = Var b
 452              | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
 453 \end{code}
 454
 455 %************************************************************************
 456 %*                                                                      *
 457 \subsection[lint-types]{Types}
 458 %*                                                                      *
 459 %************************************************************************
 460
 461 \begin{code}
 462 lintBinder :: Var -> LintM ()
 463 lintBinder v = nopL
 464 -- ToDo: lint its type
 465 -- ToDo: lint its rules
 466
 467 lintTy :: Type -> LintM ()
 468 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
 469             returnL ()
 470         -- ToDo: check the kind structure of the type
 471 \end{code}
 472
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsection[lint-monad]{The Lint monad}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 \begin{code}
 481 type LintM a = [LintLocInfo]    -- Locations
 482             -> IdSet            -- Local vars in scope
 483             -> Bag ErrMsg       -- Error messages so far
 484             -> Bag WarnMsg      -- Warning messages so far
 485             -> (Maybe a, Bag ErrMsg, Bag WarnMsg)  -- Result and error/warning messages (if any)
 486
 487 data LintLocInfo
 488   = RhsOf Id            -- The variable bound
 489   | LambdaBodyOf Id     -- The lambda-binder
 490   | BodyOfLetRec [Id]   -- One of the binders
 491   | CaseAlt CoreAlt     -- Pattern of a case alternative
 492   | AnExpr CoreExpr     -- Some expression
 493   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 494 \end{code}
 495
 496 \begin{code}
 497 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
 498 initL m
 499   = case m [] emptyVarSet emptyBag emptyBag of
 500       (_, errs, warns) -> (ifNonEmptyBag errs  pprBagOfErrors,
 501                            ifNonEmptyBag warns pprBagOfWarnings)
 502   where
 503     ifNonEmptyBag bag f | isEmptyBag bag = Nothing
 504                         | otherwise      = Just (f bag)
 505
 506 returnL :: a -> LintM a
 507 returnL r loc scope errs warns = (Just r, errs, warns)
 508
 509 nopL :: LintM a
 510 nopL loc scope errs warns = (Nothing, errs, warns)
 511
 512 thenL :: LintM a -> (a -> LintM b) -> LintM b
 513 thenL m k loc scope errs warns
 514   = case m loc scope errs warns of
 515       (Just r, errs', warns')  -> k r loc scope errs' warns'
 516       (Nothing, errs', warns') -> (Nothing, errs', warns')
 517
 518 seqL :: LintM a -> LintM b -> LintM b
 519 seqL m k loc scope errs warns
 520   = case m loc scope errs warns of
 521       (_, errs', warns') -> k loc scope errs' warns'
 522
 523 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 524 mapL f [] = returnL []
 525 mapL f (x:xs)
 526   = f x         `thenL` \ r ->
 527     mapL f xs   `thenL` \ rs ->
 528     returnL (r:rs)
 529 \end{code}
 530
 531 \begin{code}
 532 checkL :: Bool -> Message -> LintM ()
 533 checkL True  msg = nopL
 534 checkL False msg = addErrL msg
 535
 536 addErrL :: Message -> LintM a
 537 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
 538
 539 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 540 -- errors or warnings, actually... they're the same type.
 541 addErr errs_so_far msg locs
 542   = ASSERT( notNull locs )
 543     errs_so_far `snocBag` mk_msg msg
 544   where
 545    (loc, cxt1) = dumpLoc (head locs)
 546    cxts        = [snd (dumpLoc loc) | loc <- locs]
 547    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 548                | otherwise          = cxt1
 549
 550    mk_msg msg = addErrLocHdrLine loc context msg
 551
 552 addLoc :: LintLocInfo -> LintM a -> LintM a
 553 addLoc extra_loc m loc scope errs warns
 554   = m (extra_loc:loc) scope errs warns
 555
 556 addInScopeVars :: [Var] -> LintM a -> LintM a
 557 addInScopeVars ids m loc scope errs warns
 558   = m loc (scope `unionVarSet` mkVarSet ids) errs warns
 559 \end{code}
 560
 561 \begin{code}
 562 checkIdInScope :: Var -> LintM ()
 563 checkIdInScope id
 564   = checkInScope (ptext SLIT("is out of scope")) id
 565
 566 checkBndrIdInScope :: Var -> Var -> LintM ()
 567 checkBndrIdInScope binder id
 568   = checkInScope msg id
 569     where
 570      msg = ptext SLIT("is out of scope inside info for") <+>
 571            ppr binder
 572
 573 checkInScope :: SDoc -> Var -> LintM ()
 574 checkInScope loc_msg var loc scope errs warns
 575   |  mustHaveLocalBinding var && not (var `elemVarSet` scope)
 576   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
 577   | otherwise
 578   = nopL loc scope errs warns
 579
 580 checkTys :: Type -> Type -> Message -> LintM ()
 581 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 582 -- annotations need only be consistent, not equal)
 583 checkTys ty1 ty2 msg
 584   | ty1 `eqType` ty2 = nopL
 585   | otherwise        = addErrL msg
 586 \end{code}
 587
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsection{Error messages}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 \begin{code}
 596 dumpLoc (RhsOf v)
 597   = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
 598
 599 dumpLoc (LambdaBodyOf b)
 600   = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
 601
 602 dumpLoc (BodyOfLetRec [])
 603   = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
 604
 605 dumpLoc (BodyOfLetRec bs@(_:_))
 606   = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
 607
 608 dumpLoc (AnExpr e)
 609   = (noSrcLoc, text "In the expression:" <+> ppr e)
 610
 611 dumpLoc (CaseAlt (con, args, rhs))
 612   = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
 613
 614 dumpLoc (ImportedUnfolding locn)
 615   = (locn, brackets (ptext SLIT("in an imported unfolding")))
 616
 617 pp_binders :: [Var] -> SDoc
 618 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 619
 620 pp_binder :: Var -> SDoc
 621 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 622             | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 623 \end{code}
 624
 625 \begin{code}
 626 ------------------------------------------------------
 627 --      Messages for case expressions
 628
 629 mkNullAltsMsg :: CoreExpr -> Message
 630 mkNullAltsMsg e
 631   = hang (text "Case expression with no alternatives:")
 632          4 (ppr e)
 633
 634 mkDefaultArgsMsg :: [Var] -> Message
 635 mkDefaultArgsMsg args
 636   = hang (text "DEFAULT case with binders")
 637          4 (ppr args)
 638
 639 mkCaseAltMsg :: CoreExpr -> Message
 640 mkCaseAltMsg e
 641   = hang (text "Type of case alternatives not the same:")
 642          4 (ppr e)
 643
 644 mkScrutMsg :: Id -> Type -> Message
 645 mkScrutMsg var scrut_ty
 646   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 647           text "Result binder type:" <+> ppr (idType var),
 648           text "Scrutinee type:" <+> ppr scrut_ty]
 649
 650
 651 mkNonDefltMsg e
 652   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 653
 654 nonExhaustiveAltsMsg :: CoreExpr -> Message
 655 nonExhaustiveAltsMsg e
 656   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 657
 658 mkBadPatMsg :: Type -> Type -> Message
 659 mkBadPatMsg con_result_ty scrut_ty
 660   = vcat [
 661         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 662         text "Pattern result type:" <+> ppr con_result_ty,
 663         text "Scrutinee type:" <+> ppr scrut_ty
 664     ]
 665
 666 ------------------------------------------------------
 667 --      Other error messages
 668
 669 mkAppMsg :: Type -> Type -> Message
 670 mkAppMsg fun arg
 671   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 672               hang (ptext SLIT("Fun type:")) 4 (ppr fun),
 673               hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
 674
 675 mkKindErrMsg :: TyVar -> Type -> Message
 676 mkKindErrMsg tyvar arg_ty
 677   = vcat [ptext SLIT("Kinds don't match in type application:"),
 678           hang (ptext SLIT("Type variable:"))
 679                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 680           hang (ptext SLIT("Arg type:"))
 681                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 682
 683 mkTyAppMsg :: Type -> Type -> Message
 684 mkTyAppMsg ty arg_ty
 685   = vcat [text "Illegal type application:",
 686               hang (ptext SLIT("Exp type:"))
 687                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 688               hang (ptext SLIT("Arg type:"))
 689                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 690
 691 mkRhsMsg :: Id -> Type -> Message
 692 mkRhsMsg binder ty
 693   = vcat
 694     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 695             ppr binder],
 696      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 697      hsep [ptext SLIT("Rhs type:"), ppr ty]]
 698
 699 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 700 mkRhsPrimMsg binder rhs
 701   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 702                      ppr binder],
 703               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
 704              ]
 705
 706 mkUnboxedTupleMsg :: Id -> Message
 707 mkUnboxedTupleMsg binder
 708   = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
 709           hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
 710
 711 mkCoerceErr from_ty expr_ty
 712   = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
 713           ptext SLIT("From-type:") <+> ppr from_ty,
 714           ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
 715     ]
 716
 717 mkStrangeTyMsg e
 718   = ptext SLIT("Type where expression expected:") <+> ppr e
 719 \end{code}