%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19931998
%
A ``lint'' pass to check for Core correctness
\begin{code}
module CoreLint (
lintCoreBindings,
lintUnfolding,
showPass, endPass, endPassIf, endIteration
) where
#include "HsVersions.h"
import NewDemand
import CoreSyn
import CoreFVs
import CoreUtils
import Bag
import Literal
import DataCon
import TysWiredIn
import Var
import VarEnv
import VarSet
import Name
import Id
import IdInfo
import PprCore
import ErrUtils
import SrcLoc
import Type
import Coercion
import TyCon
import BasicTypes
import StaticFlags
import ListSetOps
import DynFlags
import Outputable
import FastString
import Util
import Data.Maybe
\end{code}
%************************************************************************
%* *
\subsection{End pass}
%* *
%************************************************************************
@showPass@ and @endPass@ don't really belong here, but it makes a convenient
place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endPass = dumpAndLint dumpIfSet_core
endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endPassIf cond = dumpAndLint (dumpIf_core cond)
endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
endIteration = dumpAndLint dumpIfSet_dyn
dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
-> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
dumpAndLint dump dflags pass_name dump_flag binds
= do
debugTraceMsg dflags 2 $
(text " Result size =" <+> int (coreBindsSize binds))
dump dflags dump_flag pass_name (pprCoreBindings binds)
lintCoreBindings dflags pass_name binds
\end{code}
%************************************************************************
%* *
\subsection[lintCoreBindings]{@lintCoreBindings@: Toplevel interface}
%* *
%************************************************************************
Checks that a set of core bindings is wellformed. The PprStyle and String
just control what we print in the event of an error. The Bool value
indicates whether we have done any specialisation yet (in which case we do
some extra checks).
We check for
(a) type errors
(b) Outofscope type variables
(c) Outofscope local variables
(d) Illkinded types
If we have done specialisation the we check that there are
(a) No toplevel bindings of primitive (unboxed type)
Outstanding issues:
Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
In the desugarer, it's very very convenient to be able to say (in effect)
let a = Type Int in <body>
That is, use a type let. See Note [Type let] in CoreSyn.
However, when linting <body> we need to remember that a=Int, else we might
reject a correct program. So we carry a type substitution (in this example
[a -> Int]) and apply this substitution before comparing types. The functin
lintTy :: Type -> LintM Type
returns a substituted type; that's the only reason it returns anything.
When we encounter a binder (like x::a) we must apply the substitution
to the type of the binding variable. lintBinders does this.
For Ids, the typesubstituted Id is added to the in_scope set (which
itself is part of the TvSubst we are carrying down), and when we
find an occurence of an Id, we fetch it from the inscope set.
\begin{code}
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
lintCoreBindings dflags _whoDunnit _binds
| not (dopt Opt_DoCoreLinting dflags)
= return ()
lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
ghcExit dflags 1
where
lint_binds binds = addLoc TopLevelBindings $
addInScopeVars (bindersOfBinds binds) $
mapM lint_bind binds
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
display bad_news
= vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
bad_news,
ptext (sLit "*** Offending Program ***"),
pprCoreBindings binds,
ptext (sLit "*** End of Offense ***")
]
\end{code}
%************************************************************************
%* *
\subsection[lintUnfolding]{lintUnfolding}
%* *
%************************************************************************
We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
\begin{code}
lintUnfolding :: SrcLoc
-> [Var]
-> CoreExpr
-> Maybe Message
lintUnfolding locn vars expr
= initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
lintCoreExpr expr)
\end{code}
%************************************************************************
%* *
\subsection[lintCoreBinding]{lintCoreBinding}
%* *
%************************************************************************
Check a core binding, returning the list of variables bound.
\begin{code}
lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
do { ty <- lintCoreExpr rhs
; lintBinder binder
; binder_ty <- applySubst binder_ty
; checkTys binder_ty ty (mkRhsMsg binder ty)
; checkL (not (isUnLiftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs)
; checkL (not (isStrictId binder)
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
(mkStrictMsg binder)
; mapM_ (checkBndrIdInScope binder) bndr_vars
; checkL (case maybeDmdTy of
Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
Nothing -> True)
(mkArityMsg binder) }
where
binder_ty = idType binder
maybeDmdTy = idNewStrictness_maybe binder
bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
| otherwise = emptyVarSet
wkr_info = idWorkerInfo binder
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
\end{code}
%************************************************************************
%* *
\subsection[lintCoreExpr]{lintCoreExpr}
%* *
%************************************************************************
\begin{code}
type InType = Type
type OutType = Type
lintCoreExpr :: CoreExpr -> LintM OutType
lintCoreExpr (Var var)
= do { checkL (not (var == oneTupleDataConId))
(ptext (sLit "Illegal one-tuple"))
; checkDeadIdOcc var
; var' <- lookupIdInScope var
; return (idType var')
}
lintCoreExpr (Lit lit)
= return (literalType lit)
lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
; co' <- lintTy co
; let (from_ty, to_ty) = coercionKind co'
; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
; return to_ty }
lintCoreExpr (Note _ expr)
= lintCoreExpr expr
lintCoreExpr (Let (NonRec tv (Type ty)) body)
=
do { checkL (isTyVar tv) (mkKindErrMsg tv ty)
; ty' <- lintTy ty
; kind' <- lintTy (tyVarKind tv)
; let tv' = setTyVarKind tv kind'
; checkKinds tv' ty'
; addLoc (BodyOfLetRec [tv]) $
addInScopeVars [tv'] $
extendSubstL tv' ty' $
lintCoreExpr body }
lintCoreExpr (Let (NonRec bndr rhs) body)
= do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
; addLoc (BodyOfLetRec [bndr])
(lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
do { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
lintCoreExpr e@(App fun arg)
= do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $
lintCoreArg fun_ty arg }
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
lintBinders [var] $ \[var'] ->
do { body_ty <- lintCoreExpr expr
; if isId var' then
return (mkFunTy (idType var') body_ty)
else
return (mkForAllTy var' body_ty)
}
lintCoreExpr e@(Case scrut var alt_ty alts) =
do { scrut_ty <- lintCoreExpr scrut
; alt_ty <- lintTy alt_ty
; var_ty <- lintTy (idType var)
; let mb_tc_app = splitTyConApp_maybe (idType var)
; case mb_tc_app of
Just (tycon, _)
| debugIsOn &&
isAlgTyCon tycon &&
not (isOpenTyCon tycon) &&
null (tyConDataCons tycon) ->
pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
$ return ()
_otherwise -> return ()
; subst <- getTvSubst
; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
; let scope = if (isUnboxedTupleType (idType var)) then
pass_var
else lintAndScopeId var
; scope $ \_ ->
do {
mapM_ (lintCoreAlt scrut_ty alt_ty) alts
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
pass_var f = f var
lintCoreExpr (Type ty)
= do { ty' <- lintTy ty
; return (typeKind ty') }
\end{code}
%************************************************************************
%* *
\subsection[lintCoreArgs]{lintCoreArgs}
%* *
%************************************************************************
The basic version of these functions checks that the argument is a
subtype of the required type, as one would expect.
\begin{code}
lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
lintCoreArg :: OutType -> CoreArg -> LintM OutType
\end{code}
\begin{code}
lintCoreArgs ty [] = return ty
lintCoreArgs ty (a : args) =
do { res <- lintCoreArg ty a
; lintCoreArgs res args }
lintCoreArg fun_ty (Type arg_ty) =
do { arg_ty <- lintTy arg_ty
; lintTyApp fun_ty arg_ty }
lintCoreArg fun_ty arg =
do { arg_ty <- lintCoreExpr arg
; let err1 = mkAppMsg fun_ty arg_ty arg
err2 = mkNonFunAppMsg fun_ty arg_ty arg
; case splitFunTy_maybe fun_ty of
Just (arg,res) ->
do { checkTys arg arg_ty err1
; return res }
_ -> addErrL err2 }
\end{code}
\begin{code}
lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp ty arg_ty
= case splitForAllTy_maybe ty of
Nothing -> addErrL (mkTyAppMsg ty arg_ty)
Just (tyvar,body)
-> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
; checkKinds tyvar arg_ty
; return (substTyWith [tyvar] [arg_ty] body) }
checkKinds :: Var -> Type -> LintM ()
checkKinds tyvar arg_ty
= checkL (arg_kind `isSubKind` tyvar_kind)
(mkKindErrMsg tyvar arg_ty)
where
tyvar_kind = tyVarKind tyvar
arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
| otherwise = typeKind arg_ty
checkDeadIdOcc :: Id -> LintM ()
checkDeadIdOcc id
| isDeadOcc (idOccInfo id)
= do { in_case <- inCasePat
; checkL in_case
(ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
| otherwise
= return ()
\end{code}
%************************************************************************
%* *
\subsection[lintCoreAlts]{lintCoreAlts}
%* *
%************************************************************************
\begin{code}
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
checkCaseAlts e _ []
= addErrL (mkNullAltsMsg e)
checkCaseAlts e ty alts =
do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
; checkL (isJust maybe_deflt || not is_infinite_ty)
(nonExhaustiveAltsMsg e) }
where
(con_alts, maybe_deflt) = findDefault alts
increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
increasing_tag _ = True
non_deflt (DEFAULT, _, _) = False
non_deflt _ = True
is_infinite_ty = case splitTyConApp_maybe ty of
Nothing -> False
Just (tycon, _) -> isPrimTyCon tycon
\end{code}
\begin{code}
checkAltExpr :: CoreExpr -> OutType -> LintM ()
checkAltExpr expr ann_ty
= do { actual_ty <- lintCoreExpr expr
; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
lintCoreAlt :: OutType
-> OutType
-> CoreAlt
-> LintM ()
lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
do { checkL (null args) (mkDefaultArgsMsg args)
; checkAltExpr rhs alt_ty }
lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
do { checkL (null args) (mkDefaultArgsMsg args)
; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
; checkAltExpr rhs alt_ty }
where
lit_ty = literalType lit
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
| isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
| Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
= addLoc (CaseAlt alt) $ do
{
checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
; lintBinders args $ \ args -> do
{ addLoc (CasePat alt) $ do
{
; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
}
; checkAltExpr rhs alt_ty } }
| otherwise
= addErrL (mkBadAltMsg scrut_ty alt)
\end{code}
%************************************************************************
%* *
\subsection[linttypes]{Types}
%* *
%************************************************************************
\begin{code}
lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
lintBinders [] linterF = linterF []
lintBinders (var:vars) linterF = lintBinder var $ \var' ->
lintBinders vars $ \ vars' ->
linterF (var':vars')
lintBinder :: Var -> (Var -> LintM a) -> LintM a
lintBinder var linterF
| isTyVar var = lint_ty_bndr
| otherwise = lintIdBndr var linterF
where
lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
; subst <- getTvSubst
; let (subst', tv') = substTyVarBndr subst var
; updateTvSubst subst' (linterF tv') }
lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
lintIdBndr id linterF
= do { checkL (not (isUnboxedTupleType (idType id)))
(mkUnboxedTupleMsg id)
; lintAndScopeId id $ \id' -> linterF id'
}
lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
lintAndScopeIds ids linterF
= go ids
where
go [] = linterF []
go (id:ids) = do { lintAndScopeId id $ \id ->
lintAndScopeIds ids $ \ids ->
linterF (id:ids) }
lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
lintAndScopeId id linterF
= do { ty <- lintTy (idType id)
; let id' = setIdType id ty
; addInScopeVars [id'] $ (linterF id')
}
lintTy :: InType -> LintM OutType
lintTy ty
= do { ty' <- applySubst ty
; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
; return ty' }
\end{code}
%************************************************************************
%* *
\subsection[lintmonad]{The Lint monad}
%* *
%************************************************************************
\begin{code}
newtype LintM a =
LintM { unLintM ::
[LintLocInfo] ->
TvSubst ->
Bag Message ->
(Maybe a, Bag Message) }
instance Monad LintM where
return x = LintM (\ _ _ errs -> (Just x, errs))
fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
m >>= k = LintM (\ loc subst errs ->
let (res, errs') = unLintM m loc subst errs in
case res of
Just r -> unLintM (k r) loc subst errs'
Nothing -> (Nothing, errs'))
data LintLocInfo
= RhsOf Id
| LambdaBodyOf Id
| BodyOfLetRec [Id]
| CaseAlt CoreAlt
| CasePat CoreAlt
| AnExpr CoreExpr
| ImportedUnfolding SrcLoc
| TopLevelBindings
\end{code}
\begin{code}
initL :: LintM a -> Maybe Message
initL m
= case unLintM m [] emptyTvSubst emptyBag of
(_, errs) | isEmptyBag errs -> Nothing
| otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
\end{code}
\begin{code}
checkL :: Bool -> Message -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
addErrL :: Message -> LintM a
addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr subst errs_so_far msg locs
= ASSERT( notNull locs )
errs_so_far `snocBag` mk_msg msg
where
(loc, cxt1) = dumpLoc (head locs)
cxts = [snd (dumpLoc loc) | loc <- locs]
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
ptext (sLit "Substitution:") <+> ppr subst
| otherwise = cxt1
mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m =
LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
inCasePat :: LintM Bool
inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
where
is_case_pat (CasePat {} : _) = True
is_case_pat _other = False
addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars vars m
| null dups
= LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
| otherwise
= addErrL (dupVars dups)
where
(_, dups) = removeDups compare vars
updateTvSubst :: TvSubst -> LintM a -> LintM a
updateTvSubst subst' m =
LintM (\ loc _ errs -> unLintM m loc subst' errs)
getTvSubst :: LintM TvSubst
getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
applySubst :: Type -> LintM Type
applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
= LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
\end{code}
\begin{code}
lookupIdInScope :: Id -> LintM Id
lookupIdInScope id
| not (mustHaveLocalBinding id)
= return id
| otherwise
= do { subst <- getTvSubst
; case lookupInScope (getTvInScope subst) id of
Just v -> return v
Nothing -> do { _ <- addErrL out_of_scope
; return id } }
where
out_of_scope = ppr id <+> ptext (sLit "is out of scope")
oneTupleDataConId :: Id
oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
checkBndrIdInScope :: Var -> Var -> LintM ()
checkBndrIdInScope binder id
= checkInScope msg id
where
msg = ptext (sLit "is out of scope inside info for") <+>
ppr binder
checkTyVarInScope :: TyVar -> LintM ()
checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
checkInScope :: SDoc -> Var -> LintM ()
checkInScope loc_msg var =
do { subst <- getTvSubst
; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
(hsep [ppr var, loc_msg]) }
checkTys :: Type -> Type -> Message -> LintM ()
checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
\end{code}
%************************************************************************
%* *
\subsection{Error messages}
%* *
%************************************************************************
\begin{code}
dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
dumpLoc (RhsOf v)
= (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
dumpLoc (LambdaBodyOf b)
= (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
dumpLoc (BodyOfLetRec [])
= (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
dumpLoc (BodyOfLetRec bs@(_:_))
= ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
dumpLoc (AnExpr e)
= (noSrcLoc, text "In the expression:" <+> ppr e)
dumpLoc (CaseAlt (con, args, _))
= (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
dumpLoc (CasePat (con, args, _))
= (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext (sLit "in an imported unfolding")))
dumpLoc TopLevelBindings
= (noSrcLoc, empty)
pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
pp_binder :: Var -> SDoc
pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
| otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
\end{code}
\begin{code}
mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
mkCaseAltMsg e ty1 ty2
= hang (text "Type of case alternatives not the same as the annotation on case:")
4 (vcat [ppr ty1, ppr ty2, ppr e])
mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
mkScrutMsg var var_ty scrut_ty subst
= vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
text "Result binder type:" <+> ppr var_ty,
text "Scrutinee type:" <+> ppr scrut_ty,
hsep [ptext (sLit "Current TV subst"), ppr subst]]
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
mkNonIncreasingAltsMsg e
= hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
mkBadConMsg :: TyCon -> DataCon -> Message
mkBadConMsg tycon datacon
= vcat [
text "In a case alternative, data constructor isn't in scrutinee type:",
text "Scrutinee type constructor:" <+> ppr tycon,
text "Data con:" <+> ppr datacon
]
mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
= vcat [
text "In a case alternative, pattern result type doesn't match scrutinee type:",
text "Pattern result type:" <+> ppr con_result_ty,
text "Scrutinee type:" <+> ppr scrut_ty
]
mkBadAltMsg :: Type -> CoreAlt -> Message
mkBadAltMsg scrut_ty alt
= vcat [ text "Data alternative when scrutinee is not a tycon application",
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
mkNewTyDataConAltMsg scrut_ty alt
= vcat [ text "Data alternative for newtype datacon",
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
mkAppMsg :: Type -> Type -> CoreExpr -> Message
mkAppMsg fun_ty arg_ty arg
= vcat [ptext (sLit "Argument value doesn't match argument type:"),
hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
mkNonFunAppMsg fun_ty arg_ty arg
= vcat [ptext (sLit "Non-function type in function position"),
hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
= vcat [ptext (sLit "Kinds don't match in type application:"),
hang (ptext (sLit "Type variable:"))
4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (ptext (sLit "Exp type:"))
4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkRhsMsg :: Id -> Type -> Message
mkRhsMsg binder ty
= vcat
[hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]]
mkRhsPrimMsg :: Id -> CoreExpr -> Message
mkRhsPrimMsg binder _rhs
= vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
]
mkStrictMsg :: Id -> Message
mkStrictMsg binder
= vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
ppr binder],
hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
]
mkArityMsg :: Id -> Message
mkArityMsg binder
= vcat [hsep [ptext (sLit "Demand type has "),
ppr (dmdTypeDepth dmd_ty),
ptext (sLit " arguments, rhs has "),
ppr (idArity binder),
ptext (sLit "arguments, "),
ppr binder],
hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
]
where (StrictSig dmd_ty) = idNewStrictness binder
mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder
= vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
mkCastErr :: Type -> Type -> Message
mkCastErr from_ty expr_ty
= vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
ptext (sLit "From-type:") <+> ppr from_ty,
ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
]
dupVars :: [[Var]] -> Message
dupVars vars
= hang (ptext (sLit "Duplicate variables brought into scope"))
2 (ppr vars)
\end{code}