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