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