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