import VarSet
import Name
import Id
+import IdInfo
import PprCore
import ErrUtils
import SrcLoc
where
binder_ty = idType binder
maybeDmdTy = idNewStrictness_maybe binder
- bndr_vars = varSetElems (idFreeVars 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}
lintCoreExpr (Var var)
= do { checkL (not (var == oneTupleDataConId))
(ptext (sLit "Illegal one-tuple"))
+
+ ; checkDeadIdOcc var
; var' <- lookupIdInScope var
; return (idType var')
}
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))
-- This can legitimately happen for type families
tyvar_kind = tyVarKind tyvar
arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
| otherwise = typeKind arg_ty
+
+checkDeadIdOcc :: Id -> LintM ()
+-- Occurrences of an Id should never be dead....
+-- except when we are checking a case pattern
+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}
lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
lintAndScopeId id linterF
= do { ty <- lintTy (idType id)
- ; let id' = Var.setIdType id ty
+ ; let id' = setIdType id ty
; addInScopeVars [id'] $ (linterF id')
}
| LambdaBodyOf Id -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
| CaseAlt CoreAlt -- Case alternative
- | CasePat CoreAlt -- *Pattern* of the case alternative
+ | CasePat CoreAlt -- The *pattern* of the case alternative
| AnExpr CoreExpr -- Some expression
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
| TopLevelBindings
addLoc extra_loc m =
LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
+inCasePat :: LintM Bool -- A slight hack; see the unique call site
+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