compiler/coreSyn/CoreLint.lhs

   1
   2 %
   3 % (c) The University of Glasgow 2006
   4 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   5 %
   6
   7 A ``lint'' pass to check for Core correctness
   8
   9 \begin{code}
  10 module CoreLint ( lintCoreBindings, lintUnfolding ) where
  11
  12 #include "HsVersions.h"
  13
  14 import NewDemand
  15 import CoreSyn
  16 import CoreFVs
  17 import CoreUtils
  18 import Bag
  19 import Literal
  20 import DataCon
  21 import TysWiredIn
  22 import Var
  23 import VarEnv
  24 import VarSet
  25 import Name
  26 import Id
  27 import PprCore
  28 import ErrUtils
  29 import SrcLoc
  30 import Type
  31 import Coercion
  32 import TyCon
  33 import BasicTypes
  34 import StaticFlags
  35 import ListSetOps
  36 import DynFlags
  37 import Outputable
  38 import FastString
  39 import Util
  40 import Data.Maybe
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 Checks that a set of core bindings is well-formed.  The PprStyle and String
  50 just control what we print in the event of an error.  The Bool value
  51 indicates whether we have done any specialisation yet (in which case we do
  52 some extra checks).
  53
  54 We check for
  55         (a) type errors
  56         (b) Out-of-scope type variables
  57         (c) Out-of-scope local variables
  58         (d) Ill-kinded types
  59
  60 If we have done specialisation the we check that there are
  61         (a) No top-level bindings of primitive (unboxed type)
  62
  63 Outstanding issues:
  64
  65     --
  66     -- Things are *not* OK if:
  67     --
  68     --  * Unsaturated type app before specialisation has been done;
  69     --
  70     --  * Oversaturated type app after specialisation (eta reduction
  71     --   may well be happening...);
  72
  73
  74 Note [Linting type lets]
  75 ~~~~~~~~~~~~~~~~~~~~~~~~
  76 In the desugarer, it's very very convenient to be able to say (in effect)
  77         let a = Type Int in <body>
  78 That is, use a type let.   See Note [Type let] in CoreSyn.
  79
  80 However, when linting <body> we need to remember that a=Int, else we might
  81 reject a correct program.  So we carry a type substitution (in this example
  82 [a -> Int]) and apply this substitution before comparing types.  The functin
  83         lintTy :: Type -> LintM Type
  84 returns a substituted type; that's the only reason it returns anything.
  85
  86 When we encounter a binder (like x::a) we must apply the substitution
  87 to the type of the binding variable.  lintBinders does this.
  88
  89 For Ids, the type-substituted Id is added to the in_scope set (which
  90 itself is part of the TvSubst we are carrying down), and when we
  91 find an occurence of an Id, we fetch it from the in-scope set.
  92
  93
  94 \begin{code}
  95 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
  96
  97 lintCoreBindings dflags _whoDunnit _binds
  98   | not (dopt Opt_DoCoreLinting dflags)
  99   = return ()
 100
 101 lintCoreBindings dflags whoDunnit binds
 102   = case (initL (lint_binds binds)) of
 103       Nothing       -> showPass dflags ("Core Linted result of " ++ whoDunnit)
 104       Just bad_news -> printDump (display bad_news)     >>
 105                        ghcExit dflags 1
 106   where
 107         -- Put all the top-level binders in scope at the start
 108         -- This is because transformation rules can bring something
 109         -- into use 'unexpectedly'
 110     lint_binds binds = addLoc TopLevelBindings $
 111                        addInScopeVars (bindersOfBinds binds) $
 112                        mapM lint_bind binds
 113
 114     lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
 115     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
 116
 117     display bad_news
 118       = vcat [  text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 119                 bad_news,
 120                 ptext (sLit "*** Offending Program ***"),
 121                 pprCoreBindings binds,
 122                 ptext (sLit "*** End of Offense ***")
 123         ]
 124 \end{code}
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection[lintUnfolding]{lintUnfolding}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 We use this to check all unfoldings that come in from interfaces
 133 (it is very painful to catch errors otherwise):
 134
 135 \begin{code}
 136 lintUnfolding :: SrcLoc
 137               -> [Var]          -- Treat these as in scope
 138               -> CoreExpr
 139               -> Maybe Message  -- Nothing => OK
 140
 141 lintUnfolding locn vars expr
 142   = initL (addLoc (ImportedUnfolding locn) $
 143            addInScopeVars vars             $
 144            lintCoreExpr expr)
 145 \end{code}
 146
 147 %************************************************************************
 148 %*                                                                      *
 149 \subsection[lintCoreBinding]{lintCoreBinding}
 150 %*                                                                      *
 151 %************************************************************************
 152
 153 Check a core binding, returning the list of variables bound.
 154
 155 \begin{code}
 156 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
 157 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 158   = addLoc (RhsOf binder) $
 159          -- Check the rhs
 160     do { ty <- lintCoreExpr rhs
 161        ; lintBinder binder -- Check match to RHS type
 162        ; binder_ty <- applySubst binder_ty
 163        ; checkTys binder_ty ty (mkRhsMsg binder ty)
 164         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 165        ; checkL (not (isUnLiftedType binder_ty)
 166             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 167            (mkRhsPrimMsg binder rhs)
 168         -- Check that if the binder is top-level or recursive, it's not demanded
 169        ; checkL (not (isStrictId binder)
 170             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
 171            (mkStrictMsg binder)
 172         -- Check whether binder's specialisations contain any out-of-scope variables
 173        ; mapM_ (checkBndrIdInScope binder) bndr_vars
 174
 175       -- Check whether arity and demand type are consistent (only if demand analysis
 176       -- already happened)
 177        ; checkL (case maybeDmdTy of
 178                   Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
 179                   Nothing -> True)
 180            (mkArityMsg binder) }
 181
 182         -- We should check the unfolding, if any, but this is tricky because
 183         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 184    where
 185     binder_ty                  = idType binder
 186     maybeDmdTy                 = idNewStrictness_maybe binder
 187     bndr_vars                  = varSetElems (idFreeVars binder)
 188     lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
 189                    | otherwise = return ()
 190 \end{code}
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[lintCoreExpr]{lintCoreExpr}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 \begin{code}
 199 type InType  = Type     -- Substitution not yet applied
 200 type OutType = Type     -- Substitution has been applied to this
 201
 202 lintCoreExpr :: CoreExpr -> LintM OutType
 203 -- The returned type has the substitution from the monad
 204 -- already applied to it:
 205 --      lintCoreExpr e subst = exprType (subst e)
 206 --
 207 -- The returned "type" can be a kind, if the expression is (Type ty)
 208
 209 lintCoreExpr (Var var)
 210   = do  { checkL (not (var == oneTupleDataConId))
 211                  (ptext (sLit "Illegal one-tuple"))
 212
 213         ; checkDeadIdOcc var
 214         ; var' <- lookupIdInScope var
 215         ; return (idType var')
 216         }
 217
 218 lintCoreExpr (Lit lit)
 219   = return (literalType lit)
 220
 221 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 222 --  = do        { expr_ty <- lintCoreExpr expr
 223 --      ; to_ty <- lintTy to_ty
 224 --      ; from_ty <- lintTy from_ty
 225 --      ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
 226 --      ; return to_ty }
 227
 228 lintCoreExpr (Cast expr co)
 229   = do { expr_ty <- lintCoreExpr expr
 230        ; co' <- lintTy co
 231        ; let (from_ty, to_ty) = coercionKind co'
 232        ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
 233        ; return to_ty }
 234
 235 lintCoreExpr (Note _ expr)
 236   = lintCoreExpr expr
 237
 238 lintCoreExpr (Let (NonRec tv (Type ty)) body)
 239   =     -- See Note [Type let] in CoreSyn
 240     do  { checkL (isTyVar tv) (mkKindErrMsg tv ty)      -- Not quite accurate
 241         ; ty' <- lintTy ty
 242         ; kind' <- lintTy (tyVarKind tv)
 243         ; let tv' = setTyVarKind tv kind'
 244         ; checkKinds tv' ty'
 245                 -- Now extend the substitution so we
 246                 -- take advantage of it in the body
 247         ; addLoc (BodyOfLetRec [tv]) $
 248           addInScopeVars [tv'] $
 249           extendSubstL tv' ty' $
 250           lintCoreExpr body }
 251
 252 lintCoreExpr (Let (NonRec bndr rhs) body)
 253   = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
 254         ; addLoc (BodyOfLetRec [bndr])
 255                  (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
 256
 257 lintCoreExpr (Let (Rec pairs) body)
 258   = lintAndScopeIds bndrs       $ \_ ->
 259     do  { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
 260         ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
 261   where
 262     bndrs = map fst pairs
 263
 264 lintCoreExpr e@(App fun arg)
 265   = do  { fun_ty <- lintCoreExpr fun
 266         ; addLoc (AnExpr e) $
 267           lintCoreArg fun_ty arg }
 268
 269 lintCoreExpr (Lam var expr)
 270   = addLoc (LambdaBodyOf var) $
 271     lintBinders [var] $ \[var'] ->
 272     do { body_ty <- lintCoreExpr expr
 273        ; if isId var' then
 274              return (mkFunTy (idType var') body_ty)
 275          else
 276              return (mkForAllTy var' body_ty)
 277        }
 278         -- The applySubst is needed to apply the subst to var
 279
 280 lintCoreExpr e@(Case scrut var alt_ty alts) =
 281        -- Check the scrutinee
 282   do { scrut_ty <- lintCoreExpr scrut
 283      ; alt_ty   <- lintTy alt_ty
 284      ; var_ty   <- lintTy (idType var)
 285
 286      ; let mb_tc_app = splitTyConApp_maybe (idType var)
 287      ; case mb_tc_app of
 288          Just (tycon, _)
 289               | debugIsOn &&
 290                 isAlgTyCon tycon &&
 291                 not (isOpenTyCon tycon) &&
 292                 null (tyConDataCons tycon) ->
 293                   pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
 294                         -- This can legitimately happen for type families
 295                       $ return ()
 296          _otherwise -> return ()
 297
 298         -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
 299
 300      ; subst <- getTvSubst
 301      ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
 302
 303      -- If the binder is an unboxed tuple type, don't put it in scope
 304      ; let scope = if (isUnboxedTupleType (idType var)) then
 305                        pass_var
 306                    else lintAndScopeId var
 307      ; scope $ \_ ->
 308        do { -- Check the alternatives
 309             mapM_ (lintCoreAlt scrut_ty alt_ty) alts
 310           ; checkCaseAlts e scrut_ty alts
 311           ; return alt_ty } }
 312   where
 313     pass_var f = f var
 314
 315 lintCoreExpr (Type ty)
 316   = do { ty' <- lintTy ty
 317        ; return (typeKind ty') }
 318 \end{code}
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 \subsection[lintCoreArgs]{lintCoreArgs}
 323 %*                                                                      *
 324 %************************************************************************
 325
 326 The basic version of these functions checks that the argument is a
 327 subtype of the required type, as one would expect.
 328
 329 \begin{code}
 330 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
 331 lintCoreArg  :: OutType -> CoreArg   -> LintM OutType
 332 -- First argument has already had substitution applied to it
 333 \end{code}
 334
 335 \begin{code}
 336 lintCoreArgs ty [] = return ty
 337 lintCoreArgs ty (a : args) =
 338   do { res <- lintCoreArg ty a
 339      ; lintCoreArgs res args }
 340
 341 lintCoreArg fun_ty (Type arg_ty) =
 342   do { arg_ty <- lintTy arg_ty
 343      ; lintTyApp fun_ty arg_ty }
 344
 345 lintCoreArg fun_ty arg =
 346        -- Make sure function type matches argument
 347   do { arg_ty <- lintCoreExpr arg
 348      ; let err1 =  mkAppMsg fun_ty arg_ty arg
 349            err2 = mkNonFunAppMsg fun_ty arg_ty arg
 350      ; case splitFunTy_maybe fun_ty of
 351         Just (arg,res) ->
 352           do { checkTys arg arg_ty err1
 353              ; return res }
 354         _ -> addErrL err2 }
 355 \end{code}
 356
 357 \begin{code}
 358 -- Both args have had substitution applied
 359 lintTyApp :: OutType -> OutType -> LintM OutType
 360 lintTyApp ty arg_ty
 361   = case splitForAllTy_maybe ty of
 362       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 363
 364       Just (tyvar,body)
 365         -> do   { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
 366                 ; checkKinds tyvar arg_ty
 367                 ; return (substTyWith [tyvar] [arg_ty] body) }
 368
 369 checkKinds :: Var -> Type -> LintM ()
 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 (arg_kind `isSubKind` tyvar_kind)
 376            (mkKindErrMsg tyvar arg_ty)
 377   where
 378     tyvar_kind = tyVarKind tyvar
 379     arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
 380              | otherwise     = typeKind arg_ty
 381
 382 checkDeadIdOcc :: Id -> LintM ()
 383 -- Occurrences of an Id should never be dead....
 384 -- except when we are checking a case pattern
 385 checkDeadIdOcc id
 386   | isDeadOcc (idOccInfo id)
 387   = do { in_case <- inCasePat
 388        ; checkL in_case
 389                 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
 390   | otherwise
 391   = return ()
 392 \end{code}
 393
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection[lintCoreAlts]{lintCoreAlts}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 \begin{code}
 402 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 403 -- a) Check that the alts are non-empty
 404 -- b1) Check that the DEFAULT comes first, if it exists
 405 -- b2) Check that the others are in increasing order
 406 -- c) Check that there's a default for infinite types
 407 -- NB: Algebraic cases are not necessarily exhaustive, because
 408 --     the simplifer correctly eliminates case that can't
 409 --     possibly match.
 410
 411 checkCaseAlts e _ []
 412   = addErrL (mkNullAltsMsg e)
 413
 414 checkCaseAlts e ty alts =
 415   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
 416      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
 417      ; checkL (isJust maybe_deflt || not is_infinite_ty)
 418            (nonExhaustiveAltsMsg e) }
 419   where
 420     (con_alts, maybe_deflt) = findDefault alts
 421
 422         -- Check that successive alternatives have increasing tags
 423     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
 424     increasing_tag _                         = True
 425
 426     non_deflt (DEFAULT, _, _) = False
 427     non_deflt _               = True
 428
 429     is_infinite_ty = case splitTyConApp_maybe ty of
 430                         Nothing         -> False
 431                         Just (tycon, _) -> isPrimTyCon tycon
 432 \end{code}
 433
 434 \begin{code}
 435 checkAltExpr :: CoreExpr -> OutType -> LintM ()
 436 checkAltExpr expr ann_ty
 437   = do { actual_ty <- lintCoreExpr expr
 438        ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
 439
 440 lintCoreAlt :: OutType          -- Type of scrutinee
 441             -> OutType          -- Type of the alternative
 442             -> CoreAlt
 443             -> LintM ()
 444
 445 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
 446   do { checkL (null args) (mkDefaultArgsMsg args)
 447      ; checkAltExpr rhs alt_ty }
 448
 449 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
 450   do { checkL (null args) (mkDefaultArgsMsg args)
 451      ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
 452      ; checkAltExpr rhs alt_ty }
 453   where
 454     lit_ty = literalType lit
 455
 456 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 457   | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
 458   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
 459   = addLoc (CaseAlt alt) $  do
 460     {   -- First instantiate the universally quantified
 461         -- type variables of the data constructor
 462         -- We've already check
 463       checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
 464     ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
 465
 466         -- And now bring the new binders into scope
 467     ; lintBinders args $ \ args -> do
 468     { addLoc (CasePat alt) $ do
 469           {    -- Check the pattern
 470                  -- Scrutinee type must be a tycon applicn; checked by caller
 471                  -- This code is remarkably compact considering what it does!
 472                  -- NB: args must be in scope here so that the lintCoreArgs
 473                  --     line works.
 474                  -- NB: relies on existential type args coming *after*
 475                  --     ordinary type args
 476           ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
 477           ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 478           }
 479                -- Check the RHS
 480     ; checkAltExpr rhs alt_ty } }
 481
 482   | otherwise   -- Scrut-ty is wrong shape
 483   = addErrL (mkBadAltMsg scrut_ty alt)
 484 \end{code}
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection[lint-types]{Types}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 \begin{code}
 493 -- When we lint binders, we (one at a time and in order):
 494 --  1. Lint var types or kinds (possibly substituting)
 495 --  2. Add the binder to the in scope set, and if its a coercion var,
 496 --     we may extend the substitution to reflect its (possibly) new kind
 497 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
 498 lintBinders [] linterF = linterF []
 499 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
 500                                  lintBinders vars $ \ vars' ->
 501                                  linterF (var':vars')
 502
 503 lintBinder :: Var -> (Var -> LintM a) -> LintM a
 504 lintBinder var linterF
 505   | isTyVar var = lint_ty_bndr
 506   | otherwise   = lintIdBndr var linterF
 507   where
 508     lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
 509                       ; subst <- getTvSubst
 510                       ; let (subst', tv') = substTyVarBndr subst var
 511                       ; updateTvSubst subst' (linterF tv') }
 512
 513 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
 514 -- Do substitution on the type of a binder and add the var with this
 515 -- new type to the in-scope set of the second argument
 516 -- ToDo: lint its rules
 517 lintIdBndr id linterF
 518   = do  { checkL (not (isUnboxedTupleType (idType id)))
 519                  (mkUnboxedTupleMsg id)
 520                 -- No variable can be bound to an unboxed tuple.
 521         ; lintAndScopeId id $ \id' -> linterF id'
 522         }
 523
 524 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
 525 lintAndScopeIds ids linterF
 526   = go ids
 527   where
 528     go []       = linterF []
 529     go (id:ids) = do { lintAndScopeId id $ \id ->
 530                            lintAndScopeIds ids $ \ids ->
 531                            linterF (id:ids) }
 532
 533 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
 534 lintAndScopeId id linterF
 535   = do { ty <- lintTy (idType id)
 536        ; let id' = setIdType id ty
 537        ; addInScopeVars [id'] $ (linterF id')
 538        }
 539
 540 lintTy :: InType -> LintM OutType
 541 -- Check the type, and apply the substitution to it
 542 -- See Note [Linting type lets]
 543 -- ToDo: check the kind structure of the type
 544 lintTy ty
 545   = do  { ty' <- applySubst ty
 546         ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
 547         ; return ty' }
 548 \end{code}
 549
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsection[lint-monad]{The Lint monad}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 \begin{code}
 558 newtype LintM a =
 559    LintM { unLintM ::
 560             [LintLocInfo] ->         -- Locations
 561             TvSubst ->               -- Current type substitution; we also use this
 562                                      -- to keep track of all the variables in scope,
 563                                      -- both Ids and TyVars
 564             Bag Message ->           -- Error messages so far
 565             (Maybe a, Bag Message) } -- Result and error messages (if any)
 566
 567 {-      Note [Type substitution]
 568         ~~~~~~~~~~~~~~~~~~~~~~~~
 569 Why do we need a type substitution?  Consider
 570         /\(a:*). \(x:a). /\(a:*). id a x
 571 This is ill typed, because (renaming variables) it is really
 572         /\(a:*). \(x:a). /\(b:*). id b x
 573 Hence, when checking an application, we can't naively compare x's type
 574 (at its binding site) with its expected type (at a use site).  So we
 575 rename type binders as we go, maintaining a substitution.
 576
 577 The same substitution also supports let-type, current expressed as
 578         (/\(a:*). body) ty
 579 Here we substitute 'ty' for 'a' in 'body', on the fly.
 580 -}
 581
 582 instance Monad LintM where
 583   return x = LintM (\ _   _     errs -> (Just x, errs))
 584   fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
 585   m >>= k  = LintM (\ loc subst errs ->
 586                        let (res, errs') = unLintM m loc subst errs in
 587                          case res of
 588                            Just r -> unLintM (k r) loc subst errs'
 589                            Nothing -> (Nothing, errs'))
 590
 591 data LintLocInfo
 592   = RhsOf Id            -- The variable bound
 593   | LambdaBodyOf Id     -- The lambda-binder
 594   | BodyOfLetRec [Id]   -- One of the binders
 595   | CaseAlt CoreAlt     -- Case alternative
 596   | CasePat CoreAlt     -- The *pattern* of the case alternative
 597   | AnExpr CoreExpr     -- Some expression
 598   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 599   | TopLevelBindings
 600 \end{code}
 601
 602
 603 \begin{code}
 604 initL :: LintM a -> Maybe Message {- errors -}
 605 initL m
 606   = case unLintM m [] emptyTvSubst emptyBag of
 607       (_, errs) | isEmptyBag errs -> Nothing
 608                 | otherwise       -> Just (vcat (punctuate blankLine (bagToList errs)))
 609 \end{code}
 610
 611 \begin{code}
 612 checkL :: Bool -> Message -> LintM ()
 613 checkL True  _   = return ()
 614 checkL False msg = addErrL msg
 615
 616 addErrL :: Message -> LintM a
 617 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
 618
 619 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
 620 addErr subst errs_so_far msg locs
 621   = ASSERT( notNull locs )
 622     errs_so_far `snocBag` mk_msg msg
 623   where
 624    (loc, cxt1) = dumpLoc (head locs)
 625    cxts        = [snd (dumpLoc loc) | loc <- locs]
 626    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
 627                                       ptext (sLit "Substitution:") <+> ppr subst
 628                | otherwise          = cxt1
 629
 630    mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
 631
 632 addLoc :: LintLocInfo -> LintM a -> LintM a
 633 addLoc extra_loc m =
 634   LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
 635
 636 inCasePat :: LintM Bool         -- A slight hack; see the unique call site
 637 inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
 638   where
 639     is_case_pat (CasePat {} : _) = True
 640     is_case_pat _other           = False
 641
 642 addInScopeVars :: [Var] -> LintM a -> LintM a
 643 addInScopeVars vars m
 644   | null dups
 645   = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
 646   | otherwise
 647   = addErrL (dupVars dups)
 648   where
 649     (_, dups) = removeDups compare vars
 650
 651 updateTvSubst :: TvSubst -> LintM a -> LintM a
 652 updateTvSubst subst' m =
 653   LintM (\ loc _ errs -> unLintM m loc subst' errs)
 654
 655 getTvSubst :: LintM TvSubst
 656 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 657
 658 applySubst :: Type -> LintM Type
 659 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
 660
 661 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 662 extendSubstL tv ty m
 663   = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
 664 \end{code}
 665
 666 \begin{code}
 667 lookupIdInScope :: Id -> LintM Id
 668 lookupIdInScope id
 669   | not (mustHaveLocalBinding id)
 670   = return id   -- An imported Id
 671   | otherwise
 672   = do  { subst <- getTvSubst
 673         ; case lookupInScope (getTvInScope subst) id of
 674                 Just v  -> return v
 675                 Nothing -> do { _ <- addErrL out_of_scope
 676                               ; return id } }
 677   where
 678     out_of_scope = ppr id <+> ptext (sLit "is out of scope")
 679
 680
 681 oneTupleDataConId :: Id -- Should not happen
 682 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
 683
 684 checkBndrIdInScope :: Var -> Var -> LintM ()
 685 checkBndrIdInScope binder id
 686   = checkInScope msg id
 687     where
 688      msg = ptext (sLit "is out of scope inside info for") <+>
 689            ppr binder
 690
 691 checkTyVarInScope :: TyVar -> LintM ()
 692 checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
 693
 694 checkInScope :: SDoc -> Var -> LintM ()
 695 checkInScope loc_msg var =
 696  do { subst <- getTvSubst
 697     ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
 698              (hsep [ppr var, loc_msg]) }
 699
 700 checkTys :: Type -> Type -> Message -> LintM ()
 701 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 702 -- annotations need only be consistent, not equal)
 703 -- Assumes ty1,ty2 are have alrady had the substitution applied
 704 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
 705 \end{code}
 706
 707 %************************************************************************
 708 %*                                                                      *
 709 \subsection{Error messages}
 710 %*                                                                      *
 711 %************************************************************************
 712
 713 \begin{code}
 714 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
 715
 716 dumpLoc (RhsOf v)
 717   = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
 718
 719 dumpLoc (LambdaBodyOf b)
 720   = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
 721
 722 dumpLoc (BodyOfLetRec [])
 723   = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
 724
 725 dumpLoc (BodyOfLetRec bs@(_:_))
 726   = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
 727
 728 dumpLoc (AnExpr e)
 729   = (noSrcLoc, text "In the expression:" <+> ppr e)
 730
 731 dumpLoc (CaseAlt (con, args, _))
 732   = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
 733
 734 dumpLoc (CasePat (con, args, _))
 735   = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
 736
 737 dumpLoc (ImportedUnfolding locn)
 738   = (locn, brackets (ptext (sLit "in an imported unfolding")))
 739 dumpLoc TopLevelBindings
 740   = (noSrcLoc, empty)
 741
 742 pp_binders :: [Var] -> SDoc
 743 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 744
 745 pp_binder :: Var -> SDoc
 746 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 747             | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 748 \end{code}
 749
 750 \begin{code}
 751 ------------------------------------------------------
 752 --      Messages for case expressions
 753
 754 mkNullAltsMsg :: CoreExpr -> Message
 755 mkNullAltsMsg e
 756   = hang (text "Case expression with no alternatives:")
 757          4 (ppr e)
 758
 759 mkDefaultArgsMsg :: [Var] -> Message
 760 mkDefaultArgsMsg args
 761   = hang (text "DEFAULT case with binders")
 762          4 (ppr args)
 763
 764 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
 765 mkCaseAltMsg e ty1 ty2
 766   = hang (text "Type of case alternatives not the same as the annotation on case:")
 767          4 (vcat [ppr ty1, ppr ty2, ppr e])
 768
 769 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
 770 mkScrutMsg var var_ty scrut_ty subst
 771   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 772           text "Result binder type:" <+> ppr var_ty,--(idType var),
 773           text "Scrutinee type:" <+> ppr scrut_ty,
 774      hsep [ptext (sLit "Current TV subst"), ppr subst]]
 775
 776 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
 777 mkNonDefltMsg e
 778   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 779 mkNonIncreasingAltsMsg e
 780   = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
 781
 782 nonExhaustiveAltsMsg :: CoreExpr -> Message
 783 nonExhaustiveAltsMsg e
 784   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 785
 786 mkBadConMsg :: TyCon -> DataCon -> Message
 787 mkBadConMsg tycon datacon
 788   = vcat [
 789         text "In a case alternative, data constructor isn't in scrutinee type:",
 790         text "Scrutinee type constructor:" <+> ppr tycon,
 791         text "Data con:" <+> ppr datacon
 792     ]
 793
 794 mkBadPatMsg :: Type -> Type -> Message
 795 mkBadPatMsg con_result_ty scrut_ty
 796   = vcat [
 797         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 798         text "Pattern result type:" <+> ppr con_result_ty,
 799         text "Scrutinee type:" <+> ppr scrut_ty
 800     ]
 801
 802 mkBadAltMsg :: Type -> CoreAlt -> Message
 803 mkBadAltMsg scrut_ty alt
 804   = vcat [ text "Data alternative when scrutinee is not a tycon application",
 805            text "Scrutinee type:" <+> ppr scrut_ty,
 806            text "Alternative:" <+> pprCoreAlt alt ]
 807
 808 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
 809 mkNewTyDataConAltMsg scrut_ty alt
 810   = vcat [ text "Data alternative for newtype datacon",
 811            text "Scrutinee type:" <+> ppr scrut_ty,
 812            text "Alternative:" <+> pprCoreAlt alt ]
 813
 814
 815 ------------------------------------------------------
 816 --      Other error messages
 817
 818 mkAppMsg :: Type -> Type -> CoreExpr -> Message
 819 mkAppMsg fun_ty arg_ty arg
 820   = vcat [ptext (sLit "Argument value doesn't match argument type:"),
 821               hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
 822               hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
 823               hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 824
 825 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
 826 mkNonFunAppMsg fun_ty arg_ty arg
 827   = vcat [ptext (sLit "Non-function type in function position"),
 828               hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
 829               hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
 830               hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 831
 832 mkKindErrMsg :: TyVar -> Type -> Message
 833 mkKindErrMsg tyvar arg_ty
 834   = vcat [ptext (sLit "Kinds don't match in type application:"),
 835           hang (ptext (sLit "Type variable:"))
 836                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 837           hang (ptext (sLit "Arg type:"))
 838                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 839
 840 mkTyAppMsg :: Type -> Type -> Message
 841 mkTyAppMsg ty arg_ty
 842   = vcat [text "Illegal type application:",
 843               hang (ptext (sLit "Exp type:"))
 844                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 845               hang (ptext (sLit "Arg type:"))
 846                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 847
 848 mkRhsMsg :: Id -> Type -> Message
 849 mkRhsMsg binder ty
 850   = vcat
 851     [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
 852             ppr binder],
 853      hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
 854      hsep [ptext (sLit "Rhs type:"), ppr ty]]
 855
 856 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 857 mkRhsPrimMsg binder _rhs
 858   = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
 859                      ppr binder],
 860               hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
 861              ]
 862
 863 mkStrictMsg :: Id -> Message
 864 mkStrictMsg binder
 865   = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
 866                      ppr binder],
 867               hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
 868              ]
 869
 870 mkArityMsg :: Id -> Message
 871 mkArityMsg binder
 872   = vcat [hsep [ptext (sLit "Demand type has "),
 873                      ppr (dmdTypeDepth dmd_ty),
 874                      ptext (sLit " arguments, rhs has "),
 875                      ppr (idArity binder),
 876                      ptext (sLit "arguments, "),
 877                      ppr binder],
 878               hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
 879
 880          ]
 881            where (StrictSig dmd_ty) = idNewStrictness binder
 882
 883 mkUnboxedTupleMsg :: Id -> Message
 884 mkUnboxedTupleMsg binder
 885   = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
 886           hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
 887
 888 mkCastErr :: Type -> Type -> Message
 889 mkCastErr from_ty expr_ty
 890   = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
 891           ptext (sLit "From-type:") <+> ppr from_ty,
 892           ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
 893     ]
 894
 895 dupVars :: [[Var]] -> Message
 896 dupVars vars
 897   = hang (ptext (sLit "Duplicate variables brought into scope"))
 898        2 (ppr vars)
 899 \end{code}