ghc/compiler/coreSyn/CoreLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CoreLint (
  10         lintCoreBindings,
  11         lintUnfolding
  12     ) where
  13
  14 IMP_Ubiq()
  15
  16 import CmdLineOpts      ( opt_D_show_passes, opt_PprUserLength, opt_DoCoreLinting )
  17 import CoreSyn
  18
  19 import Bag
  20 import Kind             ( hasMoreBoxityInfo, Kind{-instance-},
  21                           isTypeKind, isBoxedTypeKind {- TEMP --SOF -} )
  22 import Literal          ( literalType, Literal{-instance-} )
  23 import Id               ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon,
  24                           dataConArgTys, GenId{-instances-},
  25                           emptyIdSet, mkIdSet, intersectIdSets,
  26                           unionIdSets, elementOfIdSet, SYN_IE(IdSet),
  27                           SYN_IE(Id)
  28                         )
  29 import Maybes           ( catMaybes )
  30 import Name             ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
  31                           NamedThing(..) )
  32 import PprCore
  33 import Outputable       ( PprStyle(..), Outputable(..), pprErrorsStyle, printErrs )
  34 import ErrUtils         ( doIfSet, ghcExit )
  35 import PprType          ( GenType, GenTyVar, TyCon )
  36 import Pretty
  37 import PrimOp           ( primOpType, PrimOp(..) )
  38 import PrimRep          ( PrimRep(..) )
  39 import SrcLoc           ( SrcLoc )
  40 import Type             ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
  41                           getFunTyExpandingDicts_maybe,
  42                           getForAllTyExpandingDicts_maybe,
  43                           isPrimType,typeKind,instantiateTy,splitSigmaTy,
  44                           mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
  45                           maybeAppDataTyConExpandingDicts, eqTy, SYN_IE(Type)
  46                         )
  47 import TyCon            ( isPrimTyCon, isDataTyCon )
  48 import TyVar            ( tyVarKind, GenTyVar{-instances-} )
  49 import Unique           ( Unique )
  50 import Usage            ( GenUsage, SYN_IE(Usage) )
  51 import Util             ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
  52
  53 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 Checks that a set of core bindings is well-formed.  The PprStyle and String
  63 just control what we print in the event of an error.  The Bool value
  64 indicates whether we have done any specialisation yet (in which case we do
  65 some extra checks).
  66
  67 We check for
  68         (a) type errors
  69         (b) Out-of-scope type variables
  70         (c) Out-of-scope local variables
  71         (d) Ill-kinded types
  72
  73 If we have done specialisation the we check that there are
  74         (a) No top-level bindings of primitive (unboxed type)
  75
  76 Outstanding issues:
  77
  78     --
  79     -- Things are *not* OK if:
  80     --
  81     -- * Unsaturated type app before specialisation has been done;
  82     --
  83     -- * Oversaturated type app after specialisation (eta reduction
  84     --   may well be happening...);
  85     --
  86     -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
  87     --
  88
  89 \begin{code}
  90 lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO ()
  91
  92 lintCoreBindings whoDunnit spec_done binds
  93   | not opt_DoCoreLinting
  94   = return ()
  95
  96 lintCoreBindings whoDunnit spec_done binds
  97   = case (initL (lint_binds binds) spec_done) of
  98       Nothing       -> doIfSet opt_D_show_passes
  99                         (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
 100
 101       Just bad_news -> printErrs (display bad_news)     >>
 102                        ghcExit 1
 103   where
 104     lint_binds [] = returnL ()
 105     lint_binds (bind:binds)
 106       = lintCoreBinding bind `thenL` \binders ->
 107         addInScopeVars binders (lint_binds binds)
 108
 109     display bad_news
 110       = vcat [
 111                 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 112                 bad_news pprErrorsStyle,
 113                 ptext SLIT("*** Offending Program ***"),
 114                 pprCoreBindings pprErrorsStyle binds,
 115                 ptext SLIT("*** End of Offense ***")
 116         ]
 117 \end{code}
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection[lintUnfolding]{lintUnfolding}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 We use this to check all unfoldings that come in from interfaces
 126 (it is very painful to catch errors otherwise):
 127
 128 \begin{code}
 129 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
 130
 131 lintUnfolding locn expr
 132   = case
 133       (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
 134        True{-pretend spec done-})
 135     of
 136       Nothing  -> Just expr
 137       Just msg ->
 138         pprTrace "WARNING: Discarded bad unfolding from interface:\n"
 139         (vcat [msg (PprForUser opt_PprUserLength),
 140                    ptext SLIT("*** Bad unfolding ***"),
 141                    ppr PprDebug expr,
 142                    ptext SLIT("*** End unfolding ***")])
 143         Nothing
 144 \end{code}
 145
 146 %************************************************************************
 147 %*                                                                      *
 148 \subsection[lintCoreBinding]{lintCoreBinding}
 149 %*                                                                      *
 150 %************************************************************************
 151
 152 Check a core binding, returning the list of variables bound.
 153
 154 \begin{code}
 155 lintCoreBinding :: CoreBinding -> LintM [Id]
 156
 157 lintCoreBinding (NonRec binder rhs)
 158   = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
 159
 160 lintCoreBinding (Rec pairs)
 161   = addInScopeVars binders (
 162       mapL lintSingleBinding pairs `seqL` returnL binders
 163     )
 164   where
 165     binders = [b | (b,_) <- pairs]
 166
 167 lintSingleBinding (binder,rhs)
 168   = addLoc (RhsOf binder) (
 169         -- Check the rhs
 170         lintCoreExpr rhs
 171
 172         `thenL` \maybe_ty ->
 173         -- Check match to RHS type
 174         (case maybe_ty of
 175           Nothing -> returnL ()
 176           Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
 177
 178         `seqL`
 179         -- Check (not isPrimType)
 180         checkIfSpecDoneL (not (isPrimType (idType binder)))
 181           (mkRhsPrimMsg binder rhs)
 182
 183         -- We should check the unfolding, if any, but this is tricky because
 184         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 185     )
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsection[lintCoreExpr]{lintCoreExpr}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 \begin{code}
 195 lintCoreExpr :: CoreExpr -> LintM (Maybe Type)  -- Nothing if error found
 196
 197 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
 198 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
 199 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
 200 lintCoreExpr e@(Coerce coercion ty expr)
 201   = lintCoercion e coercion     `seqL`
 202     lintCoreExpr expr `seqL` returnL (Just ty)
 203
 204 lintCoreExpr (Let binds body)
 205   = lintCoreBinding binds `thenL` \binders ->
 206     if (null binders) then
 207         lintCoreExpr body  -- Can't add a new source location
 208     else
 209       addLoc (BodyOfLetRec binders)
 210         (addInScopeVars binders (lintCoreExpr body))
 211
 212 lintCoreExpr e@(Con con args)
 213   = checkL (isDataCon con) (mkConErrMsg e)      `seqL`
 214     lintCoreArgs {-False-} e (dataConRepType con) args
 215     -- Note: we don't check for primitive types in these arguments
 216
 217 lintCoreExpr e@(Prim op args)
 218   = lintCoreArgs {-True-} e (primOpType op) args
 219     -- Note: we do check for primitive types in these arguments
 220
 221 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
 222   = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
 223     -- Note: we don't check for primitive types in argument to 'error'
 224
 225 lintCoreExpr e@(App fun arg)
 226   = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
 227     -- Note: we do check for primitive types in this argument
 228
 229 lintCoreExpr (Lam (ValBinder var) expr)
 230   = addLoc (LambdaBodyOf var)
 231       (addInScopeVars [var]
 232         (lintCoreExpr expr `thenMaybeL` \ty ->
 233          returnL (Just (mkFunTy (idType var) ty))))
 234
 235 lintCoreExpr (Lam (TyBinder tyvar) expr)
 236   = lintCoreExpr expr `thenMaybeL` \ty ->
 237     returnL (Just(mkForAllTy tyvar ty))
 238     -- ToDo: Should add in-scope type variable at this point
 239
 240 lintCoreExpr e@(Case scrut alts)
 241  = lintCoreExpr scrut `thenMaybeL` \ty ->
 242    lintCoreAlts alts ty
 243 \end{code}
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection[lintCoreArgs]{lintCoreArgs}
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 The boolean argument indicates whether we should flag type
 252 applications to primitive types as being errors.
 253
 254 \begin{code}
 255 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
 256
 257 lintCoreArgs _ ty [] = returnL (Just ty)
 258 lintCoreArgs e ty (a : args)
 259   = lintCoreArg  e ty  a `thenMaybeL` \ res ->
 260     lintCoreArgs e res args
 261 \end{code}
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection[lintCoreArg]{lintCoreArg}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 \begin{code}
 270 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
 271
 272 lintCoreArg e ty (LitArg lit)
 273   = -- Make sure function type matches argument
 274     case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of
 275       Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
 276       _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
 277   where
 278     lit_ty = literalType lit
 279
 280 lintCoreArg e ty (VarArg v)
 281   = -- Make sure variable is bound
 282     checkInScope v `seqL`
 283     -- Make sure function type matches argument
 284     case (getFunTyExpandingDicts_maybe False{-as above-} ty) of
 285       Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
 286       _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
 287   where
 288     var_ty = idType v
 289
 290 lintCoreArg e ty a@(TyArg arg_ty)
 291   = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
 292     case (getForAllTyExpandingDicts_maybe ty) of
 293       Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
 294
 295       Just (tyvar,body) ->
 296         let
 297             tyvar_kind = tyVarKind tyvar
 298             argty_kind = typeKind arg_ty
 299         in
 300         if argty_kind `hasMoreBoxityInfo` tyvar_kind
 301                 -- Arg type might be boxed for a function with an uncommitted
 302                 -- tyvar; notably this is used so that we can give
 303                 --      error :: forall a:*. String -> a
 304                 -- and then apply it to both boxed and unboxed types.
 305          then
 306             returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
 307         else
 308             pprTrace "lintCoreArg:kinds:" (hsep [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
 309             addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
 310
 311 lintCoreArg e ty (UsageArg u)
 312   = -- ToDo: Check that usage has no unbound usage variables
 313     case (getForAllUsageTy ty) of
 314       Just (uvar,bounds,body) ->
 315         -- ToDo: Check argument satisfies bounds
 316         returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
 317       _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
 318 \end{code}
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 \subsection[lintCoreAlts]{lintCoreAlts}
 323 %*                                                                      *
 324 %************************************************************************
 325
 326 \begin{code}
 327 lintCoreAlts :: CoreCaseAlts
 328              -> Type                    -- Type of scrutinee
 329 --           -> TyCon                   -- TyCon pinned on the case
 330              -> LintM (Maybe Type)      -- Type of alternatives
 331
 332 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
 333   = -- Check tycon is not a primitive tycon
 334 --    addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
 335 --    `seqL`
 336     -- Check we are scrutinising a proper datatype
 337     -- (ToDo: robustify)
 338 --    addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
 339 --    `seqL`
 340     lintDeflt deflt ty
 341     `thenL` \maybe_deflt_ty ->
 342     mapL (lintAlgAlt ty {-tycon-}) alts
 343     `thenL` \maybe_alt_tys ->
 344     -- Check the result types
 345     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 346       []             -> returnL Nothing
 347
 348       (first_ty:tys) -> mapL check tys  `seqL`
 349                         returnL (Just first_ty)
 350         where
 351           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 352
 353 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
 354   = -- Check tycon is a primitive tycon
 355 --    addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
 356 --    `seqL`
 357     mapL (lintPrimAlt ty) alts
 358     `thenL` \maybe_alt_tys ->
 359     lintDeflt deflt ty
 360     `thenL` \maybe_deflt_ty ->
 361     -- Check the result types
 362     case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
 363       []             -> returnL Nothing
 364
 365       (first_ty:tys) -> mapL check tys  `seqL`
 366                         returnL (Just first_ty)
 367         where
 368           check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 369
 370 lintAlgAlt scrut_ty (con,args,rhs)
 371   = (case maybeAppDataTyConExpandingDicts scrut_ty of
 372       Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
 373          let
 374            arg_tys = dataConArgTys con tys_applied
 375          in
 376          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 377          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 378                                                                  `seqL`
 379          mapL check (zipEqual "lintAlgAlt" arg_tys args)         `seqL`
 380          returnL ()
 381
 382       other -> addErrL (mkAlgAltMsg1 scrut_ty)
 383     )                                                            `seqL`
 384     addInScopeVars args         (
 385          lintCoreExpr rhs
 386     )
 387   where
 388     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 389
 390     -- elem: yes, the elem-list here can sometimes be long-ish,
 391     -- but as it's use-once, probably not worth doing anything different
 392     -- We give it its own copy, so it isn't overloaded.
 393     elem _ []       = False
 394     elem x (y:ys)   = x==y || elem x ys
 395
 396 lintPrimAlt ty alt@(lit,rhs)
 397  = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
 398    lintCoreExpr rhs
 399
 400 lintDeflt NoDefault _ = returnL Nothing
 401 lintDeflt deflt@(BindDefault binder rhs) ty
 402   = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
 403     addInScopeVars [binder] (lintCoreExpr rhs)
 404 \end{code}
 405
 406 %************************************************************************
 407 %*                                                                      *
 408 \subsection[lint-coercion]{Coercion}
 409 %*                                                                      *
 410 %************************************************************************
 411
 412 \begin{code}
 413 lintCoercion e (CoerceIn  con) = check_con e con
 414 lintCoercion e (CoerceOut con) = check_con e con
 415
 416 check_con e con = checkL (isNewCon con)
 417                          (mkCoerceErrMsg e)
 418 \end{code}
 419
 420
 421 %************************************************************************
 422 %*                                                                      *
 423 \subsection[lint-monad]{The Lint monad}
 424 %*                                                                      *
 425 %************************************************************************
 426
 427 \begin{code}
 428 type LintM a = Bool             -- True <=> specialisation has been done
 429             -> [LintLocInfo]    -- Locations
 430             -> IdSet            -- Local vars in scope
 431             -> Bag ErrMsg       -- Error messages so far
 432             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 433
 434 type ErrMsg = PprStyle -> Doc
 435
 436 data LintLocInfo
 437   = RhsOf Id            -- The variable bound
 438   | LambdaBodyOf Id     -- The lambda-binder
 439   | BodyOfLetRec [Id]   -- One of the binders
 440   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 441
 442 instance Outputable LintLocInfo where
 443     ppr sty (RhsOf v)
 444       = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']']
 445
 446     ppr sty (LambdaBodyOf b)
 447       = hcat [ppr sty (getSrcLoc b),
 448                 ptext SLIT(": [in body of lambda with binder "), pp_binder sty b, char ']']
 449
 450     ppr sty (BodyOfLetRec bs)
 451       = hcat [ppr sty (getSrcLoc (head bs)),
 452                 ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']']
 453
 454     ppr sty (ImportedUnfolding locn)
 455       = (<>) (ppr sty locn) (ptext SLIT(": [in an imported unfolding]"))
 456
 457 pp_binders :: PprStyle -> [Id] -> Doc
 458 pp_binders sty bs = sep (punctuate comma (map (pp_binder sty) bs))
 459
 460 pp_binder :: PprStyle -> Id -> Doc
 461 pp_binder sty b = hsep [ppr sty b, text "::", ppr sty (idType b)]
 462 \end{code}
 463
 464 \begin{code}
 465 initL :: LintM a -> Bool -> Maybe ErrMsg
 466 initL m spec_done
 467   = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
 468     if isEmptyBag errs then
 469         Nothing
 470     else
 471         Just ( \ sty ->
 472           vcat [ msg sty | msg <- bagToList errs ]
 473         )
 474     }
 475
 476 returnL :: a -> LintM a
 477 returnL r spec loc scope errs = (r, errs)
 478
 479 thenL :: LintM a -> (a -> LintM b) -> LintM b
 480 thenL m k spec loc scope errs
 481   = case m spec loc scope errs of
 482       (r, errs') -> k r spec loc scope errs'
 483
 484 seqL :: LintM a -> LintM b -> LintM b
 485 seqL m k spec loc scope errs
 486   = case m spec loc scope errs of
 487       (_, errs') -> k spec loc scope errs'
 488
 489 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 490 thenMaybeL m k spec loc scope errs
 491   = case m spec loc scope errs of
 492       (Nothing, errs2) -> (Nothing, errs2)
 493       (Just r,  errs2) -> k r spec loc scope errs2
 494
 495 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 496 seqMaybeL m k spec loc scope errs
 497   = case m spec loc scope errs of
 498       (Nothing, errs2) -> (Nothing, errs2)
 499       (Just _,  errs2) -> k spec loc scope errs2
 500
 501 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 502 mapL f [] = returnL []
 503 mapL f (x:xs)
 504   = f x         `thenL` \ r ->
 505     mapL f xs   `thenL` \ rs ->
 506     returnL (r:rs)
 507
 508 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 509         -- Returns Nothing if anything fails
 510 mapMaybeL f [] = returnL (Just [])
 511 mapMaybeL f (x:xs)
 512   = f x             `thenMaybeL` \ r ->
 513     mapMaybeL f xs  `thenMaybeL` \ rs ->
 514     returnL (Just (r:rs))
 515 \end{code}
 516
 517 \begin{code}
 518 checkL :: Bool -> ErrMsg -> LintM ()
 519 checkL True  msg spec loc scope errs = ((), errs)
 520 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
 521
 522 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
 523 checkIfSpecDoneL True  msg spec  loc scope errs = ((), errs)
 524 checkIfSpecDoneL False msg True  loc scope errs = ((), addErr errs msg loc)
 525 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
 526
 527 addErrIfL pred spec
 528   = if pred then addErrL spec else returnL ()
 529
 530 addErrL :: ErrMsg -> LintM ()
 531 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
 532
 533 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 534
 535 addErr errs_so_far msg locs
 536   = ASSERT (not (null locs))
 537     errs_so_far `snocBag` ( \ sty ->
 538     hang (ppr sty (head locs)) 4 (msg sty)
 539     )
 540
 541 addLoc :: LintLocInfo -> LintM a -> LintM a
 542 addLoc extra_loc m spec loc scope errs
 543   = m spec (extra_loc:loc) scope errs
 544
 545 addInScopeVars :: [Id] -> LintM a -> LintM a
 546 addInScopeVars ids m spec loc scope errs
 547   = -- We check if these "new" ids are already
 548     -- in scope, i.e., we have *shadowing* going on.
 549     -- For now, it's just a "trace"; we may make
 550     -- a real error out of it...
 551     let
 552         new_set = mkIdSet ids
 553
 554 --      shadowed = scope `intersectIdSets` new_set
 555     in
 556 --  After adding -fliberate-case, Simon decided he likes shadowed
 557 --  names after all.  WDP 94/07
 558 --  (if isEmptyUniqSet shadowed
 559 --  then id
 560 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 561     m spec loc (scope `unionIdSets` new_set) errs
 562 --  )
 563 \end{code}
 564
 565 \begin{code}
 566 checkInScope :: Id -> LintM ()
 567 checkInScope id spec loc scope errs
 568   = let
 569         id_name = getName id
 570     in
 571     if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
 572       ((),addErr errs (\sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc)
 573     else
 574       ((),errs)
 575
 576 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 577 checkTys ty1 ty2 msg spec loc scope errs
 578   = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
 579 \end{code}
 580
 581 \begin{code}
 582 mkConErrMsg e sty
 583   = ($$) (ptext SLIT("Application of newtype constructor:"))
 584             (ppr sty e)
 585
 586 mkCoerceErrMsg e sty
 587   = ($$) (ptext SLIT("Coercion using a datatype constructor:"))
 588          (ppr sty e)
 589
 590
 591 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
 592 mkCaseAltMsg alts sty
 593   = ($$) (ptext SLIT("Type of case alternatives not the same:"))
 594             (ppr sty alts)
 595
 596 mkCaseDataConMsg :: CoreExpr -> ErrMsg
 597 mkCaseDataConMsg expr sty
 598   = ($$) (ptext SLIT("A case scrutinee not of data constructor type:"))
 599             (pp_expr sty expr)
 600
 601 mkCaseNotPrimMsg :: TyCon -> ErrMsg
 602 mkCaseNotPrimMsg tycon sty
 603   = ($$) (ptext SLIT("A primitive case on a non-primitive type:"))
 604             (ppr sty tycon)
 605
 606 mkCasePrimMsg :: TyCon -> ErrMsg
 607 mkCasePrimMsg tycon sty
 608   = ($$) (ptext SLIT("An algebraic case on a primitive type:"))
 609             (ppr sty tycon)
 610
 611 mkCaseAbstractMsg :: TyCon -> ErrMsg
 612 mkCaseAbstractMsg tycon sty
 613   = ($$) (ptext SLIT("An algebraic case on some weird type:"))
 614             (ppr sty tycon)
 615
 616 mkDefltMsg :: CoreCaseDefault -> ErrMsg
 617 mkDefltMsg deflt sty
 618   = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
 619             (ppr sty deflt)
 620
 621 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
 622 mkAppMsg fun arg expr sty
 623   = vcat [ptext SLIT("Argument value doesn't match argument type:"),
 624               hang (ptext SLIT("Fun type:")) 4 (ppr sty fun),
 625               hang (ptext SLIT("Arg type:")) 4 (ppr sty arg),
 626               hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
 627
 628 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
 629 mkTyAppMsg msg ty arg expr sty
 630   = vcat [hsep [ptext msg, ptext SLIT("type application:")],
 631               hang (ptext SLIT("Exp type:"))   4 (ppr sty ty),
 632               hang (ptext SLIT("Arg type:"))   4 (ppr sty arg),
 633               hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
 634
 635 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
 636 mkUsageAppMsg ty u expr sty
 637   = vcat [ptext SLIT("Illegal usage application:"),
 638               hang (ptext SLIT("Exp type:")) 4 (ppr sty ty),
 639               hang (ptext SLIT("Usage exp:")) 4 (ppr sty u),
 640               hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
 641
 642 mkAlgAltMsg1 :: Type -> ErrMsg
 643 mkAlgAltMsg1 ty sty
 644   = ($$) (text "In some case statement, type of scrutinee is not a data type:")
 645             (ppr sty ty)
 646 --          (($$) (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
 647
 648 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 649 mkAlgAltMsg2 ty con sty
 650   = vcat [
 651         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 652         ppr sty ty,
 653         ppr sty con
 654     ]
 655
 656 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 657 mkAlgAltMsg3 con alts sty
 658   = vcat [
 659         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 660         ppr sty con,
 661         ppr sty alts
 662     ]
 663
 664 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 665 mkAlgAltMsg4 ty arg sty
 666   = vcat [
 667         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 668         ppr sty ty,
 669         ppr sty arg
 670     ]
 671
 672 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
 673 mkPrimAltMsg alt sty
 674   = ($$)
 675     (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 676             (ppr sty alt)
 677
 678 mkRhsMsg :: Id -> Type -> ErrMsg
 679 mkRhsMsg binder ty sty
 680   = vcat
 681     [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 682             ppr sty binder],
 683      hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)],
 684      hsep [ptext SLIT("Rhs type:"), ppr sty ty]]
 685
 686 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
 687 mkRhsPrimMsg binder rhs sty
 688   = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
 689                      ppr sty binder],
 690               hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)]
 691              ]
 692
 693 mkSpecTyAppMsg :: CoreArg -> ErrMsg
 694 mkSpecTyAppMsg arg sty
 695   = ($$)
 696       (ptext SLIT("Unboxed types in a type application (after specialisation):"))
 697       (ppr sty arg)
 698
 699 pp_expr :: PprStyle -> CoreExpr -> Doc
 700 pp_expr sty expr
 701   = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr
 702 \end{code}