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