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