module CoreLint (
lintCoreBindings, lintUnfolding,
lintPassResult, lintInteractiveExpr, lintExpr,
lintAnnots,
endPass, endPassIO,
dumpPassResult,
CoreLint.dumpIfSet,
) where
#include "HsVersions.h"
import CoreSyn
import CoreFVs
import CoreUtils
import CoreStats ( coreBindsStats )
import CoreMonad
import Bag
import Literal
import DataCon
import TysWiredIn
import TcType ( isFloatingTy )
import Var
import VarEnv
import VarSet
import Name
import Id
import PprCore
import ErrUtils
import Coercion
import SrcLoc
import Kind
import Type
import TyCoRep
import TyCon
import CoAxiom
import BasicTypes
import ErrUtils as Err
import StaticFlags
import ListSetOps
import PrelNames
import Outputable
import FastString
import Util
import InstEnv ( instanceDFunId )
import OptCoercion ( checkAxInstCo )
import UniqSupply
import CoreArity ( typeArity )
import Demand ( splitStrictSig, isBotRes )
import HscTypes
import DynFlags
import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
import MonadUtils
import Data.Maybe
import Pair
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass pass binds rules
= do { hsc_env <- getHscEnv
; print_unqual <- getPrintUnqualified
; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
endPassIO :: HscEnv -> PrintUnqualified
-> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPassIO hsc_env print_unqual pass binds rules
= do { dumpPassResult dflags print_unqual mb_flag
(ppr pass) (pprPassDetails pass) binds rules
; lintPassResult hsc_env pass binds }
where
dflags = hsc_dflags hsc_env
mb_flag = case coreDumpFlag pass of
Just flag | dopt flag dflags -> Just flag
| dopt Opt_D_verbose_core2core dflags -> Just flag
_ -> Nothing
dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dflags dump_me pass extra_info doc
= Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
dumpPassResult :: DynFlags
-> PrintUnqualified
-> Maybe DumpFlag
-> SDoc
-> SDoc
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
| Just flag <- mb_flag
= Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
| otherwise
= Err.debugTraceMsg dflags 2 size_doc
where
size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
dump_doc = vcat [ nest 2 extra_info
, size_doc
, blankLine
, pprCoreBindingsWithSize binds
, ppUnless (null rules) pp_rules ]
pp_rules = vcat [ blankLine
, text "------ Local rules for imported ids --------"
, pprRules rules ]
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse
coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
coreDumpFlag CorePrep = Just Opt_D_dump_prep
coreDumpFlag CoreDoPrintCore = Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Nothing
coreDumpFlag CoreDoNothing = Nothing
coreDumpFlag (CoreDoPasses {}) = Nothing
lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult hsc_env pass binds
| not (gopt Opt_DoCoreLinting dflags)
= return ()
| otherwise
= do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
; displayLintResults dflags pass warns errs binds }
where
dflags = hsc_dflags hsc_env
displayLintResults :: DynFlags -> CoreToDo
-> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
(vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
, text "*** Offending Program ***"
, pprCoreBindings binds
, text "*** End of Offense ***" ])
; Err.ghcExit dflags 1 }
| not (isEmptyBag warns)
, not opt_NoDebugOutput
, showLintWarnings pass
= log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle
(lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
| otherwise = return ()
where
lint_banner :: String -> SDoc -> SDoc
lint_banner string pass = text "*** Core Lint" <+> text string
<+> text ": in result of" <+> pass
<+> text "***"
showLintWarnings :: CoreToDo -> Bool
showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
showLintWarnings _ = True
lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr what hsc_env expr
| not (gopt Opt_DoCoreLinting dflags)
= return ()
| Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
= do { display_lint_err err
; Err.ghcExit dflags 1 }
| otherwise
= return ()
where
dflags = hsc_dflags hsc_env
display_lint_err err
= do { log_action dflags dflags NoReason Err.SevDump
noSrcSpan defaultDumpStyle
(vcat [ lint_banner "errors" (text what)
, err
, text "*** Offending Program ***"
, pprCoreExpr expr
, text "*** End of Offense ***" ])
; Err.ghcExit dflags 1 }
interactiveInScope :: HscEnv -> [Var]
interactiveInScope hsc_env
= varSetElems tyvars ++ ids
where
ictxt = hsc_IC hsc_env
(cls_insts, _fam_insts) = ic_instances ictxt
te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)
te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
ids = typeEnvIds te
tyvars = mapUnionVarSet (tyCoVarsOfType . idType) ids
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
lintCoreBindings dflags pass local_in_scope binds
= initL dflags flags $
addLoc TopLevelBindings $
addInScopeVars local_in_scope $
addInScopeVars binders $
do { checkL (null dups) (dupVars dups)
; checkL (null ext_dups) (dupExtVars ext_dups)
; mapM lint_bind binds }
where
flags = LF { lf_check_global_ids = check_globals
, lf_check_inline_loop_breakers = check_lbs }
check_globals = case pass of
CoreTidy -> False
CorePrep -> False
_ -> True
check_lbs = case pass of
CoreDesugar -> False
CoreDesugarOpt -> False
_ -> True
binders = bindersOfBinds binds
(_, dups) = removeDups compare binders
ext_dups = snd (removeDups ord_ext (map Var.varName binders))
ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
, Just m2 <- nameModule_maybe n2
= compare (m1, nameOccName n1) (m2, nameOccName n2)
| otherwise = LT
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
lintUnfolding :: DynFlags
-> SrcLoc
-> [Var]
-> CoreExpr
-> Maybe MsgDoc
lintUnfolding dflags locn vars expr
| isEmptyBag errs = Nothing
| otherwise = Just (pprMessageBag errs)
where
(_warns, errs) = initL dflags defaultLintFlags linter
linter = addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
lintCoreExpr expr
lintExpr :: DynFlags
-> [Var]
-> CoreExpr
-> Maybe MsgDoc
lintExpr dflags vars expr
| isEmptyBag errs = Nothing
| otherwise = Just (pprMessageBag errs)
where
(_warns, errs) = initL dflags defaultLintFlags linter
linter = addLoc TopLevelBindings $
addInScopeVars vars $
lintCoreExpr expr
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 <- applySubstTy (idType binder)
; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") 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)
; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
(mkNonTopExportedMsg binder)
; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
(mkNonTopExternalNameMsg binder)
; flags <- getLintFlags
; when (lf_check_inline_loop_breakers flags
&& isStrongLoopBreaker (idOccInfo binder)
&& isInlinePragma (idInlinePragma binder))
(addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
; checkL (idArity binder <= length (typeArity (idType binder)))
(text "idArity" <+> ppr (idArity binder) <+>
text "exceeds typeArity" <+>
ppr (length (typeArity (idType binder))) <> colon <+>
ppr binder)
; case splitStrictSig (idStrictness binder) of
(demands, result_info) | isBotRes result_info ->
checkL (idArity binder <= length demands)
(text "idArity" <+> ppr (idArity binder) <+>
text "exceeds arity imposed by the strictness signature" <+>
ppr (idStrictness binder) <> colon <+>
ppr binder)
_ -> return ()
; mapM_ (lintCoreRule binder_ty) (idCoreRules binder)
; lintIdUnfolding binder binder_ty (idUnfolding binder) }
where
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src
= do { ty <- lintCoreExpr rhs
; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
lintIdUnfolding _ _ _
= return ()
type InType = Type
type InCoercion = Coercion
type InVar = Var
type InTyVar = Var
type InCoVar = Var
type OutType = Type
type OutKind = Kind
type LintedType = Type
type LintedKind = Kind
type OutCoercion = Coercion
type OutVar = Var
type OutTyVar = TyVar
type OutCoVar = Var
lintCoreExpr :: CoreExpr -> LintM OutType
lintCoreExpr (Var var)
= do { checkL (isNonCoVarId var)
(text "Non term variable" <+> ppr var)
; checkDeadIdOcc var
; var' <- lookupIdInScope var
; return (idType var') }
lintCoreExpr (Lit lit)
= return (literalType lit)
lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
; co' <- applySubstCo co
; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
; lintL (classifiesTypeWithValues k2)
(text "Target of cast not # or *:" <+> ppr co)
; lintRole co' Representational r
; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
; return to_ty }
lintCoreExpr (Tick (Breakpoint _ ids) expr)
= do forM_ ids $ \id -> do
checkDeadIdOcc id
lookupIdInScope id
lintCoreExpr expr
lintCoreExpr (Tick _other_tickish expr)
= lintCoreExpr expr
lintCoreExpr (Let (NonRec tv (Type ty)) body)
| isTyVar tv
=
do { ty' <- applySubstTy ty
; lintTyBndr tv $ \ tv' ->
do { addLoc (RhsOf tv) $ lintTyKind tv' ty'
; extendSubstL tv' ty' $
addLoc (BodyOfLetRec [tv]) $
lintCoreExpr body } }
lintCoreExpr (Let (NonRec bndr rhs) body)
| isId bndr
= do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
; addLoc (BodyOfLetRec [bndr])
(lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
| otherwise
= failWithL (mkLetErr bndr rhs)
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
do { checkL (null dups) (dupVars dups)
; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
where
bndrs = map fst pairs
(_, dups) = removeDups compare bndrs
lintCoreExpr e@(App _ _)
= do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
where
(fun, args) = collectArgs e
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
lintBinder var $ \ var' ->
do { body_ty <- lintCoreExpr expr
; return $ mkPiType var' body_ty }
lintCoreExpr e@(Case scrut var alt_ty alts) =
do { scrut_ty <- lintCoreExpr scrut
; (alt_ty, _) <- lintInTy alt_ty
; (var_ty, _) <- lintInTy (idType var)
; when (null alts) $
do { checkL (not (exprIsHNF scrut))
(text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut)
; checkL (exprIsBottom scrut)
(text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut)
}
; let isLitPat (LitAlt _, _ , _) = True
isLitPat _ = False
; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
(ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
"expression with literal pattern in case " ++
"analysis (see Trac #9238).")
$$ text "scrut" <+> ppr scrut)
; case tyConAppTyCon_maybe (idType var) of
Just tycon
| debugIsOn &&
isAlgTyCon tycon &&
not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
null (tyConDataCons tycon) ->
pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
$ return ()
_otherwise -> return ()
; subst <- getTCvSubst
; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
; lintAndScopeId var $ \_ ->
do {
mapM_ (lintCoreAlt scrut_ty alt_ty) alts
; checkCaseAlts e scrut_ty alts
; return alt_ty } }
lintCoreExpr (Type ty)
= failWithL (text "Type found as expression" <+> ppr ty)
lintCoreExpr (Coercion co)
= do { (k1, k2, ty1, ty2, role) <- lintInCo co
; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }
lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg fun_ty (Type arg_ty)
= do { checkL (not (isCoercionTy arg_ty))
(text "Unnecessary coercion-to-type injection:"
<+> ppr arg_ty)
; arg_ty' <- applySubstTy arg_ty
; lintTyApp fun_ty arg_ty' }
lintCoreArg fun_ty arg
= do { arg_ty <- lintCoreExpr arg
; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
(mkLetAppMsg arg)
; lintValApp arg fun_ty arg_ty }
lintAltBinders :: OutType
-> OutType
-> [OutVar]
-> LintM ()
lintAltBinders scrut_ty con_ty []
= ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
lintAltBinders scrut_ty con_ty (bndr:bndrs)
| isTyVar bndr
= do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
; lintAltBinders scrut_ty con_ty' bndrs }
| otherwise
= do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
; lintAltBinders scrut_ty con_ty' bndrs }
lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp fun_ty arg_ty
| Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
= do { lintTyKind tv arg_ty
; in_scope <- getInScope
; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }
| otherwise
= failWithL (mkTyAppMsg fun_ty arg_ty)
lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
lintValApp arg fun_ty arg_ty
| Just (arg,res) <- splitFunTy_maybe fun_ty
= do { ensureEqTys arg arg_ty err1
; return res }
| otherwise
= failWithL err2
where
err1 = mkAppMsg fun_ty arg_ty arg
err2 = mkNonFunAppMsg fun_ty arg_ty arg
lintTyKind :: OutTyVar -> OutType -> LintM ()
lintTyKind tyvar arg_ty
= do { arg_kind <- lintType arg_ty
; unless (arg_kind `eqType` tyvar_kind)
(addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) }
where
tyvar_kind = tyVarKind tyvar
checkDeadIdOcc :: Id -> LintM ()
checkDeadIdOcc id
| isDeadOcc (idOccInfo id)
= do { in_case <- inCasePat
; checkL in_case
(text "Occurrence of a dead Id" <+> ppr id) }
| otherwise
= return ()
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
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 || null alts)
(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 tyConAppTyCon_maybe ty of
Nothing -> False
Just tycon -> isPrimTyCon tycon
lintAltExpr :: CoreExpr -> OutType -> LintM ()
lintAltExpr expr ann_ty
= do { actual_ty <- lintCoreExpr expr
; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
lintCoreAlt :: OutType
-> OutType
-> CoreAlt
-> LintM ()
lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
do { lintL (null args) (mkDefaultArgsMsg args)
; lintAltExpr rhs alt_ty }
lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
| litIsLifted lit
= failWithL integerScrutinisedMsg
| otherwise
= do { lintL (null args) (mkDefaultArgsMsg args)
; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
; lintAltExpr 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
{
lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys
; lintBinders args $ \ args' -> do
{ addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
; lintAltExpr rhs alt_ty } }
| otherwise
= addErrL (mkBadAltMsg scrut_ty alt)
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 = lintTyBndr var linterF
| isCoVar var = lintCoBndr var linterF
| otherwise = lintIdBndr var linterF
lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
lintTyBndr tv thing_inside
= do { subst <- getTCvSubst
; let (subst', tv') = substTyVarBndr subst tv
; lintKind (varType tv')
; updateTCvSubst subst' (thing_inside tv') }
lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a
lintCoBndr cv thing_inside
= do { subst <- getTCvSubst
; let (subst', cv') = substCoVarBndr subst cv
; lintKind (varType cv')
; lintL (isCoercionType (varType cv'))
(text "CoVar with non-coercion type:" <+> pprTvBndr cv)
; updateTCvSubst subst' (thing_inside cv') }
lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
lintIdBndr id linterF
= do { lintAndScopeId id $ \id' -> linterF id' }
lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
lintAndScopeIds ids linterF
= go ids
where
go [] = linterF []
go (id:ids) = lintAndScopeId id $ \id ->
lintAndScopeIds ids $ \ids ->
linterF (id:ids)
lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a
lintAndScopeId id linterF
= do { flags <- getLintFlags
; checkL (not (lf_check_global_ids flags) || isLocalId id)
(text "Non-local Id binder" <+> ppr id)
; (ty, k) <- lintInTy (idType id)
; lintL (not (isRuntimeRepPolymorphic k))
(text "RuntimeRep-polymorphic binder:" <+>
(ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
; let id' = setIdType id ty
; addInScopeVar id' $ (linterF id') }
lintInTy :: InType -> LintM (LintedType, LintedKind)
lintInTy ty
= addLoc (InType ty) $
do { ty' <- applySubstTy ty
; k <- lintType ty'
; lintKind k
; return (ty', k) }
checkTyCon :: TyCon -> LintM ()
checkTyCon tc
= checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
lintType :: OutType -> LintM LintedKind
lintType (TyVarTy tv)
= do { checkL (isTyVar tv) (mkBadTyVarMsg tv)
; lintTyCoVarInScope tv
; return (tyVarKind tv) }
lintType ty@(AppTy t1 t2)
| TyConApp {} <- t1
= failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty
| otherwise
= do { k1 <- lintType t1
; k2 <- lintType t2
; lint_ty_app ty k1 [(t2,k2)] }
lintType ty@(TyConApp tc tys)
| Just ty' <- coreView ty
= lintType ty'
| isUnliftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
, length tys < tyConArity tc
= failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
| otherwise
= do { checkTyCon tc
; ks <- mapM lintType tys
; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
lintType ty@(ForAllTy (Anon t1) t2)
= do { k1 <- lintType t1
; k2 <- lintType t2
; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
lintType t@(ForAllTy (Named tv _vis) ty)
= do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t)
; lintTyBndr tv $ \tv' ->
do { k <- lintType ty
; lintL (not (tv' `elemVarSet` tyCoVarsOfType k))
(text "Variable escape in forall:" <+> ppr t)
; lintL (classifiesTypeWithValues k)
(text "Non-* and non-# kind in forall:" <+> ppr t)
; return k }}
lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
lintType (CastTy ty co)
= do { k1 <- lintType ty
; (k1', k2) <- lintStarCoercion co
; ensureEqTys k1 k1' (mkCastErr ty co k1' k1)
; return k2 }
lintType (CoercionTy co)
= do { (k1, k2, ty1, ty2, r) <- lintCoercion co
; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }
lintKind :: OutKind -> LintM ()
lintKind k = do { sk <- lintType k
; unless ((isStarKind sk) || (isUnliftedTypeKind sk))
(addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
2 (text "has kind:" <+> ppr sk))) }
lintStar :: SDoc -> OutKind -> LintM ()
lintStar doc k
= lintL (classifiesTypeWithValues k)
(text "Non-*-like kind when *-like expected:" <+> ppr k $$
text "when checking" <+> doc)
lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
lintArrow what k1 k2
= do { unless (okArrowArgKind k1) (addErrL (msg (text "argument") k1))
; unless (okArrowResultKind k2) (addErrL (msg (text "result") k2))
; return liftedTypeKind }
where
msg ar k
= vcat [ hang (text "Ill-kinded" <+> ar)
2 (text "in" <+> what)
, what <+> text "kind:" <+> ppr k ]
lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
lint_ty_app ty k tys
= lint_app (text "type" <+> quotes (ppr ty)) k tys
lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
lint_co_app ty k tys
= lint_app (text "coercion" <+> quotes (ppr ty)) k tys
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumTyLit n)
| n >= 0 = return ()
| otherwise = failWithL msg
where msg = text "Negative type literal:" <+> integer n
lintTyLit (StrTyLit _) = return ()
lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
lint_app doc kfn kas
= do { in_scope <- getInScope
; foldlM (go_app in_scope) kfn kas }
where
fail_msg = vcat [ hang (text "Kind application error in") 2 doc
, nest 2 (text "Function kind =" <+> ppr kfn)
, nest 2 (text "Arg kinds =" <+> ppr kas) ]
go_app in_scope kfn ka
| Just kfn' <- coreView kfn
= go_app in_scope kfn' ka
go_app _ (ForAllTy (Anon kfa) kfb) (_,ka)
= do { unless (ka `eqType` kfa) (addErrL fail_msg)
; return kfb }
go_app in_scope (ForAllTy (Named kv _vis) kfn) (ta,ka)
= do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg)
; return (substTyWithInScope in_scope [kv] [ta] kfn) }
go_app _ _ _ = failWithL fail_msg
lintCoreRule :: OutType -> CoreRule -> LintM ()
lintCoreRule _ (BuiltinRule {})
= return ()
lintCoreRule fun_ty (Rule { ru_name = name, ru_bndrs = bndrs
, ru_args = args, ru_rhs = rhs })
= lintBinders bndrs $ \ _ ->
do { lhs_ty <- foldM lintCoreArg fun_ty args
; rhs_ty <- lintCoreExpr rhs
; ensureEqTys lhs_ty rhs_ty $
(rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty
, text "rhs type:" <+> ppr rhs_ty ])
; let bad_bndrs = filterOut (`elemVarSet` exprsFreeVars args) bndrs
; checkL (null bad_bndrs)
(rule_doc <+> text "unbound" <+> ppr bad_bndrs)
}
where
rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon
lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
lintInCo co
= addLoc (InCo co) $
do { co' <- applySubstCo co
; lintCoercion co' }
lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)
lintStarCoercion g
= do { (k1, k2, t1, t2, r) <- lintCoercion g
; lintStar (text "the kind of the left type in" <+> ppr g) k1
; lintStar (text "the kind of the right type in" <+> ppr g) k2
; lintRole g Nominal r
; return (t1, t2) }
lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
lintCoercion (Refl r ty)
= do { k <- lintType ty
; return (k, k, ty, ty, r) }
lintCoercion co@(TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [co1,co2] <- cos
= do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
; (k2,k'2,s2,t2,r2) <- lintCoercion co2
; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2
; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2
; lintRole co1 r r1
; lintRole co2 r r2
; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) }
| Just {} <- synTyConDefn_maybe tc
= failWithL (text "Synonym in TyConAppCo:" <+> ppr co)
| otherwise
= do { checkTyCon tc
; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos
; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's)
; k <- lint_co_app co (tyConKind tc) (ts `zip` ks)
; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs
; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) }
lintCoercion co@(AppCo co1 co2)
| TyConAppCo {} <- co1
= failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)
| Refl _ (TyConApp {}) <- co1
= failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
| otherwise
= do { (k1,k2,s1,s2,r1) <- lintCoercion co1
; (k'1, k'2, t1, t2, r2) <- lintCoercion co2
; k3 <- lint_co_app co k1 [(t1,k'1)]
; k4 <- lint_co_app co k2 [(t2,k'2)]
; if r1 == Phantom
then lintL (r2 == Phantom || r2 == Nominal)
(text "Second argument in AppCo cannot be R:" $$
ppr co)
else lintRole co Nominal r2
; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) }
lintCoercion (ForAllCo tv1 kind_co co)
= do { (_, k2) <- lintStarCoercion kind_co
; let tv2 = setTyVarKind tv1 k2
; addInScopeVar tv1 $
do {
; (k3, k4, t1, t2, r) <- lintCoercion co
; in_scope <- getInScope
; let tyl = mkNamedForAllTy tv1 Invisible t1
subst = mkTvSubst in_scope $
unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)
tyr = mkNamedForAllTy tv2 Invisible $
substTy subst t2
; return (k3, k4, tyl, tyr, r) } }
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
= failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)
2 (text "With offending type:" <+> ppr (varType cv)))
| otherwise
= do { lintTyCoVarInScope cv
; cv' <- lookupIdInScope cv
; lintUnliftedCoVar cv
; return $ coVarKindsTypesRole cv' }
lintCoercion co@(UnivCo prov r ty1 ty2)
= do { k1 <- lintType ty1
; k2 <- lintType ty2
; case prov of
UnsafeCoerceProv -> return ()
PhantomProv kco -> do { lintRole co Phantom r
; check_kinds kco k1 k2 }
ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $
mkBadProofIrrelMsg ty1 co
; lintL (isCoercionTy ty2) $
mkBadProofIrrelMsg ty2 co
; check_kinds kco k1 k2 }
PluginProv _ -> return ()
HoleProv h -> addErrL $
text "Unfilled coercion hole:" <+> ppr h
; when (r /= Phantom && classifiesTypeWithValues k1
&& classifiesTypeWithValues k2)
(checkTypes ty1 ty2)
; return (k1, k2, ty1, ty2, r) }
where
report s = hang (text $ "Unsafe coercion between " ++ s)
2 (vcat [ text "From:" <+> ppr ty1
, text " To:" <+> ppr ty2])
isUnBoxed :: PrimRep -> Bool
isUnBoxed PtrRep = False
isUnBoxed _ = True
checkTypes t1 t2
= case (repType t1, repType t2) of
(UnaryRep _, UnaryRep _) ->
validateCoercion (typePrimRep t1)
(typePrimRep t2)
(UbxTupleRep rep1, UbxTupleRep rep2) -> do
checkWarnL (length rep1 == length rep2)
(report "unboxed tuples of different length")
zipWithM_ checkTypes rep1 rep2
_ -> addWarnL (report "unboxed tuple and ordinary type")
validateCoercion :: PrimRep -> PrimRep -> LintM ()
validateCoercion rep1 rep2
= do { dflags <- getDynFlags
; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
(report "unboxed and boxed value")
; checkWarnL (TyCon.primRepSizeW dflags rep1
== TyCon.primRepSizeW dflags rep2)
(report "unboxed values of different size")
; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
(TyCon.primRepIsFloat rep2)
; case fl of
Nothing -> addWarnL (report "vector types")
Just False -> addWarnL (report "float and integral values")
_ -> return ()
}
check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco
; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co)
; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }
lintCoercion (SymCo co)
= do { (k1, k2, ty1, ty2, r) <- lintCoercion co
; return (k2, k1, ty2, ty1, r) }
lintCoercion co@(TransCo co1 co2)
= do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1
; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2
; ensureEqTys ty1b ty2a
(hang (text "Trans coercion mis-match:" <+> ppr co)
2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
; lintRole co r1 r2
; return (k1a, k2b, ty1a, ty2b, r1) }
lintCoercion the_co@(NthCo n co)
= do { (_, _, s, t, r) <- lintCoercion co
; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
{ (Just (tv_s, _ty_s), Just (tv_t, _ty_t))
| n == 0
-> return (ks, kt, ts, tt, Nominal)
where
ts = tyVarKind tv_s
tt = tyVarKind tv_t
ks = typeKind ts
kt = typeKind tt
; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
{ (Just (tc_s, tys_s), Just (tc_t, tys_t))
| tc_s == tc_t
, isInjectiveTyCon tc_s r
, tys_s `equalLength` tys_t
, n < length tys_s
-> return (ks, kt, ts, tt, tr)
where
ts = getNth tys_s n
tt = getNth tys_t n
tr = nthRole r tc_s n
ks = typeKind ts
kt = typeKind tt
; _ -> failWithL (hang (text "Bad getNth:")
2 (ppr the_co $$ ppr s $$ ppr t)) }}}
lintCoercion the_co@(LRCo lr co)
= do { (_,_,s,t,r) <- lintCoercion co
; lintRole co Nominal r
; case (splitAppTy_maybe s, splitAppTy_maybe t) of
(Just s_pr, Just t_pr)
-> return (ks_pick, kt_pick, s_pick, t_pick, Nominal)
where
s_pick = pickLR lr s_pr
t_pick = pickLR lr t_pr
ks_pick = typeKind s_pick
kt_pick = typeKind t_pick
_ -> failWithL (hang (text "Bad LRCo:")
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion (InstCo co arg)
= do { (k3, k4, t1',t2', r) <- lintCoercion co
; (k1',k2',s1,s2, r') <- lintCoercion arg
; lintRole arg Nominal r'
; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of
(Just (tv1,t1), Just (tv2,t2))
| k1' `eqType` tyVarKind tv1
, k2' `eqType` tyVarKind tv2
-> return (k3, k4,
substTyWith [tv1] [s1] t1,
substTyWith [tv2] [s2] t2, r)
| otherwise
-> failWithL (text "Kind mis-match in inst coercion")
_ -> failWithL (text "Bad argument of inst") }
lintCoercion co@(AxiomInstCo con ind cos)
= do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))
(bad_ax (text "index out of range"))
; let CoAxBranch { cab_tvs = ktvs
, cab_cvs = cvs
, cab_roles = roles
, cab_lhs = lhs
, cab_rhs = rhs } = coAxiomNthBranch con ind
; unless (length ktvs + length cvs == length cos) $
bad_ax (text "lengths")
; subst <- getTCvSubst
; let empty_subst = zapTCvSubst subst
; (subst_l, subst_r) <- foldlM check_ki
(empty_subst, empty_subst)
(zip3 (ktvs ++ cvs) roles cos)
; let lhs' = substTys subst_l lhs
rhs' = substTy subst_r rhs
; case checkAxInstCo co of
Just bad_branch -> bad_ax $ text "inconsistent with" <+>
pprCoAxBranch con bad_branch
Nothing -> return ()
; let s2 = mkTyConApp (coAxiomTyCon con) lhs'
; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }
where
bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what)
2 (ppr co))
check_ki (subst_l, subst_r) (ktv, role, arg)
= do { (k', k'', s', t', r) <- lintCoercion arg
; lintRole arg role r
; let ktv_kind_l = substTy subst_l (tyVarKind ktv)
ktv_kind_r = substTy subst_r (tyVarKind ktv)
; unless (k' `eqType` ktv_kind_l)
(bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] ))
; unless (k'' `eqType` ktv_kind_r)
(bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] ))
; return (extendTCvSubst subst_l ktv s',
extendTCvSubst subst_r ktv t') }
lintCoercion (CoherenceCo co1 co2)
= do { (_, k2, t1, t2, r) <- lintCoercion co1
; let lhsty = mkCastTy t1 co2
; k1' <- lintType lhsty
; return (k1', k2, lhsty, t2, r) }
lintCoercion (KindCo co)
= do { (k1, k2, _, _, _) <- lintCoercion co
; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }
lintCoercion (SubCo co')
= do { (k1,k2,s,t,r) <- lintCoercion co'
; lintRole co' Nominal r
; return (k1,k2,s,t,Representational) }
lintCoercion this@(AxiomRuleCo co cs)
= do { eqs <- mapM lintCoercion cs
; lintRoles 0 (coaxrAsmpRoles co) eqs
; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of
Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]
Just (Pair l r) ->
return (typeKind l, typeKind r, l, r, coaxrRole co) }
where
err m xs = failWithL $
hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs)
lintRoles n (e : es) ((_,_,_,_,r) : rs)
| e == r = lintRoles (n+1) es rs
| otherwise = err "Argument roles mismatch"
[ text "In argument:" <+> int (n+1)
, text "Expected:" <+> ppr e
, text "Found:" <+> ppr r ]
lintRoles _ [] [] = return ()
lintRoles n [] rs = err "Too many coercion arguments"
[ text "Expected:" <+> int n
, text "Provided:" <+> int (n + length rs) ]
lintRoles n es [] = err "Not enough coercion arguments"
[ text "Expected:" <+> int (n + length es)
, text "Provided:" <+> int n ]
lintUnliftedCoVar :: CoVar -> LintM ()
lintUnliftedCoVar cv
= when (not (isUnliftedType (coVarKind cv))) $
failWithL (text "Bad lifted equality:" <+> ppr cv
<+> dcolon <+> ppr (coVarKind cv))
data LintEnv
= LE { le_flags :: LintFlags
, le_loc :: [LintLocInfo]
, le_subst :: TCvSubst
, le_dynflags :: DynFlags
}
data LintFlags
= LF { lf_check_global_ids :: Bool
, lf_check_inline_loop_breakers :: Bool
}
defaultLintFlags :: LintFlags
defaultLintFlags = LF { lf_check_global_ids = False
, lf_check_inline_loop_breakers = True }
newtype LintM a =
LintM { unLintM ::
LintEnv ->
WarnsAndErrs ->
(Maybe a, WarnsAndErrs) }
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
instance Functor LintM where
fmap = liftM
instance Applicative LintM where
pure x = LintM $ \ _ errs -> (Just x, errs)
(<*>) = ap
instance Monad LintM where
return = pure
fail err = failWithL (text err)
m >>= k = LintM (\ env errs ->
let (res, errs') = unLintM m env errs in
case res of
Just r -> unLintM (k r) env errs'
Nothing -> (Nothing, errs'))
#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail LintM where
fail err = failWithL (text err)
#endif
instance HasDynFlags LintM where
getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
data LintLocInfo
= RhsOf Id
| LambdaBodyOf Id
| BodyOfLetRec [Id]
| CaseAlt CoreAlt
| CasePat CoreAlt
| AnExpr CoreExpr
| ImportedUnfolding SrcLoc
| TopLevelBindings
| InType Type
| InCo Coercion
initL :: DynFlags -> LintFlags -> LintM a -> WarnsAndErrs
initL dflags flags m
= case unLintM m env (emptyBag, emptyBag) of
(_, errs) -> errs
where
env = LE { le_flags = flags, le_subst = emptyTCvSubst, le_loc = [], le_dynflags = dflags }
getLintFlags :: LintM LintFlags
getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = failWithL msg
lintL :: Bool -> MsgDoc -> LintM ()
lintL = checkL
checkWarnL :: Bool -> MsgDoc -> LintM ()
checkWarnL True _ = return ()
checkWarnL False msg = addWarnL msg
failWithL :: MsgDoc -> LintM a
failWithL msg = LintM $ \ env (warns,errs) ->
(Nothing, (warns, addMsg env errs msg))
addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \ env (warns,errs) ->
(Just (), (warns, addMsg env errs msg))
addWarnL :: MsgDoc -> LintM ()
addWarnL msg = LintM $ \ env (warns,errs) ->
(Just (), (addMsg env warns msg, errs))
addMsg :: LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc
addMsg env msgs msg
= ASSERT( notNull locs )
msgs `snocBag` mk_msg msg
where
locs = le_loc env
(loc, cxt1) = dumpLoc (head locs)
cxts = [snd (dumpLoc loc) | loc <- locs]
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
text "Substitution:" <+> ppr (le_subst env)
| otherwise = cxt1
mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m
= LintM $ \ env errs ->
unLintM m (env { le_loc = extra_loc : le_loc env }) errs
inCasePat :: LintM Bool
inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
where
is_case_pat (LE { le_loc = CasePat {} : _ }) = True
is_case_pat _other = False
addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars vars m
= LintM $ \ env errs ->
unLintM m (env { le_subst = extendTCvInScopeList (le_subst env) vars })
errs
addInScopeVar :: Var -> LintM a -> LintM a
addInScopeVar var m
= LintM $ \ env errs ->
unLintM m (env { le_subst = extendTCvInScope (le_subst env) var }) errs
extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
= LintM $ \ env errs ->
unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
updateTCvSubst :: TCvSubst -> LintM a -> LintM a
updateTCvSubst subst' m
= LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs
getTCvSubst :: LintM TCvSubst
getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
getInScope :: LintM InScopeSet
getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))
applySubstTy :: InType -> LintM OutType
applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }
applySubstCo :: InCoercion -> LintM OutCoercion
applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) }
lookupIdInScope :: Id -> LintM Id
lookupIdInScope id
| not (mustHaveLocalBinding id)
= return id
| otherwise
= do { subst <- getTCvSubst
; case lookupInScope (getTCvInScope subst) id of
Just v -> return v
Nothing -> do { addErrL out_of_scope
; return id } }
where
out_of_scope = pprBndr LetBind id <+> text "is out of scope"
lintTyCoVarInScope :: Var -> LintM ()
lintTyCoVarInScope v = lintInScope (text "is out of scope") v
lintInScope :: SDoc -> Var -> LintM ()
lintInScope loc_msg var =
do { subst <- getTCvSubst
; lintL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
(hsep [pprBndr LetBind var, loc_msg]) }
ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM ()
ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg
lintRole :: Outputable thing
=> thing
-> Role
-> Role
-> LintM ()
lintRole co r1 r2
= lintL (r1 == r2)
(text "Role incompatibility: expected" <+> ppr r1 <> comma <+>
text "got" <+> ppr r2 $$
text "in" <+> ppr co)
dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
dumpLoc (RhsOf v)
= (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))
dumpLoc (LambdaBodyOf b)
= (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))
dumpLoc (BodyOfLetRec [])
= (noSrcLoc, brackets (text "In body of a letrec with no binders"))
dumpLoc (BodyOfLetRec bs@(_:_))
= ( getSrcLoc (head bs), brackets (text "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 (text "in an imported unfolding"))
dumpLoc TopLevelBindings
= (noSrcLoc, Outputable.empty)
dumpLoc (InType ty)
= (noSrcLoc, text "In the type" <+> quotes (ppr ty))
dumpLoc (InCo co)
= (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
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)]
mkDefaultArgsMsg :: [Var] -> MsgDoc
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
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 -> TCvSubst -> MsgDoc
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 [text "Current TCv subst", ppr subst]]
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
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 -> MsgDoc
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
mkBadConMsg :: TyCon -> DataCon -> MsgDoc
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 -> MsgDoc
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
]
integerScrutinisedMsg :: MsgDoc
integerScrutinisedMsg
= text "In a LitAlt, the literal is lifted (probably Integer)"
mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
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 -> MsgDoc
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 -> MsgDoc
mkAppMsg fun_ty arg_ty arg
= vcat [text "Argument value doesn't match argument type:",
hang (text "Fun type:") 4 (ppr fun_ty),
hang (text "Arg type:") 4 (ppr arg_ty),
hang (text "Arg:") 4 (ppr arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
mkNonFunAppMsg fun_ty arg_ty arg
= vcat [text "Non-function type in function position",
hang (text "Fun type:") 4 (ppr fun_ty),
hang (text "Arg type:") 4 (ppr arg_ty),
hang (text "Arg:") 4 (ppr arg)]
mkLetErr :: TyVar -> CoreExpr -> MsgDoc
mkLetErr bndr rhs
= vcat [text "Bad `let' binding:",
hang (text "Variable:")
4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
hang (text "Rhs:")
4 (ppr rhs)]
mkTyAppMsg :: Type -> Type -> MsgDoc
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (text "Exp type:")
4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
hang (text "Arg type:")
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
mkRhsMsg binder what ty
= vcat
[hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,
ppr binder],
hsep [text "Binder's type:", ppr (idType binder)],
hsep [text "Rhs type:", ppr ty]]
mkLetAppMsg :: CoreExpr -> MsgDoc
mkLetAppMsg e
= hang (text "This argument does not satisfy the let/app invariant:")
2 (ppr e)
mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc
mkRhsPrimMsg binder _rhs
= vcat [hsep [text "The type of this binder is primitive:",
ppr binder],
hsep [text "Binder's type:", ppr (idType binder)]
]
mkStrictMsg :: Id -> MsgDoc
mkStrictMsg binder
= vcat [hsep [text "Recursive or top-level binder has strict demand info:",
ppr binder],
hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]
]
mkNonTopExportedMsg :: Id -> MsgDoc
mkNonTopExportedMsg binder
= hsep [text "Non-top-level binder is marked as exported:", ppr binder]
mkNonTopExternalNameMsg :: Id -> MsgDoc
mkNonTopExternalNameMsg binder
= hsep [text "Non-top-level binder has an external name:", ppr binder]
mkKindErrMsg :: TyVar -> Type -> MsgDoc
mkKindErrMsg tyvar arg_ty
= vcat [text "Kinds don't match in type application:",
hang (text "Type variable:")
4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (text "Arg type:")
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc
mkCastErr expr co from_ty expr_ty
= vcat [text "From-type of Cast differs from type of enclosed expression",
text "From-type:" <+> ppr from_ty,
text "Type of enclosed expr:" <+> ppr expr_ty,
text "Actual enclosed expr:" <+> ppr expr,
text "Coercion used in cast:" <+> ppr co
]
mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
mkBadUnivCoMsg lr co
= text "Kind mismatch on the" <+> pprLeftOrRight lr <+>
text "side of a UnivCo:" <+> ppr co
mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
mkBadProofIrrelMsg ty co
= hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")
2 (vcat [ text "type:" <+> ppr ty
, text "co:" <+> ppr co ])
mkBadTyVarMsg :: Var -> SDoc
mkBadTyVarMsg tv
= text "Non-tyvar used in TyVarTy:"
<+> ppr tv <+> dcolon <+> ppr (varType tv)
pprLeftOrRight :: LeftOrRight -> MsgDoc
pprLeftOrRight CLeft = text "left"
pprLeftOrRight CRight = text "right"
dupVars :: [[Var]] -> MsgDoc
dupVars vars
= hang (text "Duplicate variables brought into scope")
2 (ppr vars)
dupExtVars :: [[Name]] -> MsgDoc
dupExtVars vars
= hang (text "Duplicate top-level variables with the same qualified name")
2 (ppr vars)
lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
lintAnnots pname pass guts = do
dflags <- getDynFlags
when (gopt Opt_DoAnnotationLinting dflags) $
liftIO $ Err.showPass dflags "Annotation linting - first run"
nguts <- pass guts
when (gopt Opt_DoAnnotationLinting dflags) $ do
liftIO $ Err.showPass dflags "Annotation linting - second run"
nguts' <- withoutAnnots pass guts
liftIO $ Err.showPass dflags "Annotation linting - comparison"
let binds = flattenBinds $ mg_binds nguts
binds' = flattenBinds $ mg_binds nguts'
(diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
when (not (null diffs)) $ CoreMonad.putMsg $ vcat
[ lint_banner "warning" pname
, text "Core changes with annotations:"
, withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
]
return nguts
withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
withoutAnnots pass guts = do
dflags <- getDynFlags
let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }
withoutFlag corem =
liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
getUniqueSupplyM <*> getModule <*>
getVisibleOrphanMods <*>
getPrintUnqualified <*> getSrcSpanM <*>
pure corem
let nukeTicks = stripTicksE (not . tickishIsCode)
nukeAnnotsBind :: CoreBind -> CoreBind
nukeAnnotsBind bind = case bind of
Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
NonRec b e -> NonRec b $ nukeTicks e
nukeAnnotsMod mg@ModGuts{mg_binds=binds}
= mg{mg_binds = map nukeAnnotsBind binds}
fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)