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