module Checks.WarnCheck (warnCheck) where
import Control.Monad
(filterM, foldM_, guard, liftM, liftM2, when, unless)
import Control.Monad.State.Strict (State, execState, gets, modify)
import qualified Data.IntSet as IntSet
(IntSet, empty, insert, notMember, singleton, union, unions)
import qualified Data.Map as Map (empty, insert, lookup)
import Data.Maybe
(catMaybes, fromMaybe, listToMaybe)
import Data.List
((\\), intersect, intersectBy, nub, sort, unionBy)
import Data.Char
(isLower, isUpper, toLower, toUpper, isAlpha)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Syntax
import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent)
import Base.CurryTypes (ppTypeScheme)
import Base.Messages (Message, posMessage, internalError)
import Base.NestEnv ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv
, qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv
, qualModifyNestEnv)
import Base.Types
import Base.Utils (findMultiples)
import Env.ModuleAlias
import Env.Class (ClassEnv, classMethods, hasDefaultImpl)
import Env.TypeConstructor ( TCEnv, TypeInfo (..), lookupTypeInfo
, qualLookupTypeInfo, getOrigName )
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import CompilerOpts
warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv
-> Module a -> [Message]
warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
= runOn (initWcState mid aEnv valEnv tcEnv clsEnv (wnWarnFlags wOpts) cOpts) $ do
checkImports is
checkDeclGroup ds
checkExports es
checkMissingTypeSignatures ds
checkModuleAlias is
checkCaseMode ds
where Module _ mid es is ds = fmap (const ()) mdl
type ScopeEnv = NestEnv IdInfo
data WcState = WcState
{ moduleId :: ModuleIdent
, scope :: ScopeEnv
, aliasEnv :: AliasEnv
, valueEnv :: ValueEnv
, tyConsEnv :: TCEnv
, classEnv :: ClassEnv
, warnFlags :: [WarnFlag]
, caseMode :: CaseMode
, warnings :: [Message]
}
type WCM = State WcState
initWcState :: ModuleIdent -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv
-> [WarnFlag] -> CaseMode -> WcState
initWcState mid ae ve te ce wf cm = WcState mid emptyEnv ae ve te ce wf cm []
getModuleIdent :: WCM ModuleIdent
getModuleIdent = gets moduleId
modifyScope :: (ScopeEnv -> ScopeEnv) -> WCM ()
modifyScope f = modify $ \s -> s { scope = f $ scope s }
warnFor :: WarnFlag -> WCM () -> WCM ()
warnFor f act = do
warn <- gets $ \s -> f `elem` warnFlags s
when warn act
report :: Message -> WCM ()
report w = modify $ \ s -> s { warnings = w : warnings s }
unAlias :: QualIdent -> WCM QualIdent
unAlias q = do
aEnv <- gets aliasEnv
case qidModule q of
Nothing -> return q
Just m -> case Map.lookup m aEnv of
Nothing -> return q
Just m' -> return $ qualifyWith m' (unqualify q)
ok :: WCM ()
ok = return ()
runOn :: WcState -> WCM a -> [Message]
runOn s f = sort $ warnings $ execState f s
checkExports :: Maybe ExportSpec -> WCM ()
checkExports Nothing = ok
checkExports (Just (Exporting _ exports)) = do
mapM_ visitExport exports
reportUnusedGlobalVars
where
visitExport (Export qid) = visitQId qid
visitExport _ = ok
checkImports :: [ImportDecl] -> WCM ()
checkImports = warnFor WarnMultipleImports . foldM_ checkImport Map.empty
where
checkImport env (ImportDecl pos mid _ _ spec) = case Map.lookup mid env of
Nothing -> setImportSpec env mid $ fromImpSpec spec
Just ishs -> checkImportSpec env pos mid ishs spec
checkImportSpec env _ mid (_, _) Nothing = do
report $ warnMultiplyImportedModule mid
return env
checkImportSpec env _ mid (is, hs) (Just (Importing _ is'))
| null is && any (`notElem` hs) is' = do
report $ warnMultiplyImportedModule mid
setImportSpec env mid (is', hs)
| null iis = setImportSpec env mid (is' ++ is, hs)
| otherwise = do
mapM_ (report . (warnMultiplyImportedSymbol mid) . impName) iis
setImportSpec env mid (unionBy cmpImport is' is, hs)
where iis = intersectBy cmpImport is' is
checkImportSpec env _ mid (is, hs) (Just (Hiding _ hs'))
| null ihs = setImportSpec env mid (is, hs' ++ hs)
| otherwise = do
mapM_ (report . (warnMultiplyHiddenSymbol mid) . impName) ihs
setImportSpec env mid (is, unionBy cmpImport hs' hs)
where ihs = intersectBy cmpImport hs' hs
fromImpSpec Nothing = ([], [])
fromImpSpec (Just (Importing _ is)) = (is, [])
fromImpSpec (Just (Hiding _ hs)) = ([], hs)
setImportSpec env mid ishs = return $ Map.insert mid ishs env
cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2)
= id1 == id2 && null (intersect cs1 cs2)
cmpImport i1 i2 = (impName i1) == (impName i2)
impName (Import v) = v
impName (ImportTypeAll t) = t
impName (ImportTypeWith t _) = t
warnMultiplyImportedModule :: ModuleIdent -> Message
warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text
["Module", moduleName mid, "is imported more than once"]
warnMultiplyImportedSymbol :: ModuleIdent -> Ident -> Message
warnMultiplyImportedSymbol mid ident = posMessage ident $ hsep $ map text
[ "Symbol", escName ident, "from module", moduleName mid
, "is imported more than once" ]
warnMultiplyHiddenSymbol :: ModuleIdent -> Ident -> Message
warnMultiplyHiddenSymbol mid ident = posMessage ident $ hsep $ map text
[ "Symbol", escName ident, "from module", moduleName mid
, "is hidden more than once" ]
checkDeclGroup :: [Decl ()] -> WCM ()
checkDeclGroup ds = do
mapM_ insertDecl ds
mapM_ checkDecl ds
checkRuleAdjacency ds
checkLocalDeclGroup :: [Decl ()] -> WCM ()
checkLocalDeclGroup ds = do
mapM_ checkLocalDecl ds
checkDeclGroup ds
checkRuleAdjacency :: [Decl a] -> WCM ()
checkRuleAdjacency decls = warnFor WarnDisjoinedRules
$ foldM_ check (mkIdent "", Map.empty) decls
where
check (prevId, env) (FunctionDecl p _ f _) = do
cons <- isConsId f
if cons || prevId == f
then return (f, env)
else case Map.lookup f env of
Nothing -> return (f, Map.insert f p env)
Just p' -> do
report $ warnDisjoinedFunctionRules f p'
return (f, env)
check (_ , env) _ = return (mkIdent "", env)
warnDisjoinedFunctionRules :: Ident -> Position -> Message
warnDisjoinedFunctionRules ident pos = posMessage ident $ hsep (map text
[ "Rules for function", escName ident, "are disjoined" ])
<+> parens (text "first occurrence at" <+> text (showLine pos))
checkDecl :: Decl () -> WCM ()
checkDecl (DataDecl _ _ vs cs _) = inNestedScope $ do
mapM_ insertTypeVar vs
mapM_ checkConstrDecl cs
reportUnusedTypeVars vs
checkDecl (NewtypeDecl _ _ vs nc _) = inNestedScope $ do
mapM_ insertTypeVar vs
checkNewConstrDecl nc
reportUnusedTypeVars vs
checkDecl (TypeDecl _ _ vs ty) = inNestedScope $ do
mapM_ insertTypeVar vs
checkTypeExpr ty
reportUnusedTypeVars vs
checkDecl (FunctionDecl p _ f eqs) = checkFunctionDecl p f eqs
checkDecl (PatternDecl _ p rhs) = checkPattern p >> checkRhs rhs
checkDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys
checkDecl (ClassDecl _ _ _ _ ds) = mapM_ checkDecl ds
checkDecl (InstanceDecl p cx cls ty ds) = do
checkOrphanInstance p cx cls ty
checkMissingMethodImplementations p cls ds
mapM_ checkDecl ds
checkDecl _ = ok
checkConstrDecl :: ConstrDecl -> WCM ()
checkConstrDecl (ConstrDecl _ vs _ c tys) = inNestedScope $ do
mapM_ checkTypeShadowing vs
mapM_ insertTypeVar vs
visitId c
mapM_ checkTypeExpr tys
reportUnusedTypeVars vs
checkConstrDecl (ConOpDecl _ vs _ ty1 op ty2) = inNestedScope $ do
mapM_ checkTypeShadowing vs
mapM_ insertTypeVar vs
visitId op
mapM_ checkTypeExpr [ty1, ty2]
reportUnusedTypeVars vs
checkConstrDecl (RecordDecl _ vs _ c fs) = inNestedScope $ do
mapM_ checkTypeShadowing vs
mapM_ insertTypeVar vs
visitId c
mapM_ checkTypeExpr tys
reportUnusedTypeVars vs
where
tys = [ty | FieldDecl _ _ ty <- fs]
checkNewConstrDecl :: NewConstrDecl -> WCM ()
checkNewConstrDecl (NewConstrDecl _ c ty) = do
visitId c
checkTypeExpr ty
checkNewConstrDecl (NewRecordDecl _ c (_, ty)) = do
visitId c
checkTypeExpr ty
checkTypeExpr :: TypeExpr -> WCM ()
checkTypeExpr (ConstructorType qid) = visitQTypeId qid
checkTypeExpr (ApplyType ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]
checkTypeExpr (VariableType v) = visitTypeId v
checkTypeExpr (TupleType tys) = mapM_ checkTypeExpr tys
checkTypeExpr (ListType ty) = checkTypeExpr ty
checkTypeExpr (ArrowType ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]
checkTypeExpr (ParenType ty) = checkTypeExpr ty
checkTypeExpr (ForallType vs ty) = do
mapM_ insertTypeVar vs
checkTypeExpr ty
checkLocalDecl :: Decl a -> WCM ()
checkLocalDecl (FunctionDecl _ _ f _) = checkShadowing f
checkLocalDecl (FreeDecl _ vs) = mapM_ (checkShadowing . varIdent) vs
checkLocalDecl (PatternDecl _ p _) = checkPattern p
checkLocalDecl _ = ok
checkFunctionDecl :: Position -> Ident -> [Equation ()] -> WCM ()
checkFunctionDecl _ _ [] = ok
checkFunctionDecl p f eqs = inNestedScope $ do
mapM_ checkEquation eqs
checkFunctionPatternMatch p f eqs
checkFunctionPatternMatch :: Position -> Ident -> [Equation ()] -> WCM ()
checkFunctionPatternMatch p f eqs = do
let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs
(nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive
when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $
warnNondetOverlapping p ("Function " ++ escName f)
checkEquation :: Equation () -> WCM ()
checkEquation (Equation _ lhs rhs) = inNestedScope $ do
checkLhs lhs
checkRhs rhs
reportUnusedVars
checkLhs :: Lhs a -> WCM ()
checkLhs (FunLhs _ ts) = do
mapM_ checkPattern ts
mapM_ (insertPattern False) ts
checkLhs (OpLhs t1 op t2) = checkLhs (FunLhs op [t1, t2])
checkLhs (ApLhs lhs ts) = do
checkLhs lhs
mapM_ checkPattern ts
mapM_ (insertPattern False) ts
checkPattern :: Pattern a -> WCM ()
checkPattern (VariablePattern _ v) = checkShadowing v
checkPattern (ConstructorPattern _ _ ps) = mapM_ checkPattern ps
checkPattern (InfixPattern a p1 f p2) = checkPattern
(ConstructorPattern a f [p1, p2])
checkPattern (ParenPattern p) = checkPattern p
checkPattern (RecordPattern _ _ fs) = mapM_ (checkField checkPattern) fs
checkPattern (TuplePattern ps) = mapM_ checkPattern ps
checkPattern (ListPattern _ ps) = mapM_ checkPattern ps
checkPattern (AsPattern v p) = checkShadowing v >> checkPattern p
checkPattern (LazyPattern p) = checkPattern p
checkPattern (FunctionPattern _ _ ps) = mapM_ checkPattern ps
checkPattern (InfixFuncPattern a p1 f p2) = checkPattern
(FunctionPattern a f [p1, p2])
checkPattern _ = ok
checkRhs :: Rhs () -> WCM ()
checkRhs (SimpleRhs _ e ds) = inNestedScope $ do
checkLocalDeclGroup ds
checkExpr e
reportUnusedVars
checkRhs (GuardedRhs ce ds) = inNestedScope $ do
checkLocalDeclGroup ds
mapM_ checkCondExpr ce
reportUnusedVars
checkCondExpr :: CondExpr () -> WCM ()
checkCondExpr (CondExpr _ c e) = checkExpr c >> checkExpr e
checkExpr :: Expression () -> WCM ()
checkExpr (Variable _ v) = visitQId v
checkExpr (Paren e) = checkExpr e
checkExpr (Typed e _) = checkExpr e
checkExpr (Record _ _ fs) = mapM_ (checkField checkExpr) fs
checkExpr (RecordUpdate e fs) = do
checkExpr e
mapM_ (checkField checkExpr) fs
checkExpr (Tuple es) = mapM_ checkExpr es
checkExpr (List _ es) = mapM_ checkExpr es
checkExpr (ListCompr e sts) = checkStatements sts e
checkExpr (EnumFrom e) = checkExpr e
checkExpr (EnumFromThen e1 e2) = mapM_ checkExpr [e1, e2]
checkExpr (EnumFromTo e1 e2) = mapM_ checkExpr [e1, e2]
checkExpr (EnumFromThenTo e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]
checkExpr (UnaryMinus e) = checkExpr e
checkExpr (Apply e1 e2) = mapM_ checkExpr [e1, e2]
checkExpr (InfixApply e1 op e2) = do
visitQId (opName op)
mapM_ checkExpr [e1, e2]
checkExpr (LeftSection e _) = checkExpr e
checkExpr (RightSection _ e) = checkExpr e
checkExpr (Lambda ps e) = inNestedScope $ do
mapM_ checkPattern ps
mapM_ (insertPattern False) ps
checkExpr e
reportUnusedVars
checkExpr (Let ds e) = inNestedScope $ do
checkLocalDeclGroup ds
checkExpr e
reportUnusedVars
checkExpr (Do sts e) = checkStatements sts e
checkExpr (IfThenElse e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]
checkExpr (Case ct e alts) = do
checkExpr e
mapM_ checkAlt alts
checkCaseAlts ct alts
checkExpr _ = ok
checkStatements :: [Statement ()] -> Expression () -> WCM ()
checkStatements [] e = checkExpr e
checkStatements (s:ss) e = inNestedScope $ do
checkStatement s >> checkStatements ss e
reportUnusedVars
checkStatement :: Statement () -> WCM ()
checkStatement (StmtExpr e) = checkExpr e
checkStatement (StmtDecl ds) = checkLocalDeclGroup ds
checkStatement (StmtBind p e) = do
checkPattern p >> insertPattern False p
checkExpr e
checkAlt :: Alt () -> WCM ()
checkAlt (Alt _ p rhs) = inNestedScope $ do
checkPattern p >> insertPattern False p
checkRhs rhs
reportUnusedVars
checkField :: (a -> WCM ()) -> Field a -> WCM ()
checkField check (Field _ _ x) = check x
checkOrphanInstance :: Position -> Context -> QualIdent -> TypeExpr -> WCM ()
checkOrphanInstance p cx cls ty = warnFor WarnOrphanInstances $ do
m <- getModuleIdent
tcEnv <- gets tyConsEnv
let ocls = getOrigName m cls tcEnv
otc = getOrigName m tc tcEnv
unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $
warnOrphanInstance p $ ppDecl $ InstanceDecl p cx cls ty []
where tc = typeConstr ty
warnOrphanInstance :: Position -> Doc -> Message
warnOrphanInstance p doc = posMessage p $ text "Orphan instance:" <+> doc
checkMissingMethodImplementations :: Position -> QualIdent -> [Decl a] -> WCM ()
checkMissingMethodImplementations p cls ds = warnFor WarnMissingMethods $ do
m <- getModuleIdent
tcEnv <- gets tyConsEnv
clsEnv <- gets classEnv
let ocls = getOrigName m cls tcEnv
ms = classMethods ocls clsEnv
mapM_ (report . warnMissingMethodImplementation p) $
filter ((null fs ||) . not . flip (hasDefaultImpl ocls) clsEnv) $ ms \\ fs
where fs = map unRenameIdent $ concatMap impls ds
warnMissingMethodImplementation :: Position -> Ident -> Message
warnMissingMethodImplementation p f = posMessage p $ hsep $ map text
["No explicit implementation for method", escName f]
checkMissingTypeSignatures :: [Decl a] -> WCM ()
checkMissingTypeSignatures ds = warnFor WarnMissingSignatures $ do
let typedFs = [f | TypeSig _ fs _ <- ds, f <- fs]
untypedFs = [f | FunctionDecl _ _ f _ <- ds, f `notElem` typedFs]
unless (null untypedFs) $ do
mid <- getModuleIdent
tyScs <- mapM getTyScheme untypedFs
mapM_ report $ zipWith (warnMissingTypeSignature mid) untypedFs tyScs
getTyScheme :: Ident -> WCM TypeScheme
getTyScheme q = do
m <- getModuleIdent
tyEnv <- gets valueEnv
return $ case qualLookupValue (qualifyWith m q) tyEnv of
[Value _ _ _ tys] -> tys
_ -> internalError $ "Checks.WarnCheck.getTyScheme: " ++ show q
warnMissingTypeSignature :: ModuleIdent -> Ident -> TypeScheme -> Message
warnMissingTypeSignature mid i tys = posMessage i $ fsep
[ text "Top-level binding with no type signature:"
, nest 2 $ text (showIdent i) <+> text "::" <+> ppTypeScheme mid tys
]
checkModuleAlias :: [ImportDecl] -> WCM ()
checkModuleAlias is = do
mid <- getModuleIdent
let alias = catMaybes [a | ImportDecl _ _ _ a _ <- is]
modClash = [a | a <- alias, a == mid]
aliasClash = findMultiples alias
unless (null modClash) $ mapM_ (report . warnModuleNameClash) modClash
unless (null aliasClash) $ mapM_ (report . warnAliasNameClash ) aliasClash
warnModuleNameClash :: ModuleIdent -> Message
warnModuleNameClash mid = posMessage mid $ hsep $ map text
["The module alias", escModuleName mid
, "overlaps with the current module name"]
warnAliasNameClash :: [ModuleIdent] -> Message
warnAliasNameClash [] = internalError
"WarnCheck.warnAliasNameClash: empty list"
warnAliasNameClash mids = posMessage (head mids) $ text
"Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids))
where myppAlias mid@(ModuleIdent pos _) =
ppLine pos <> text ":" <+> text (escModuleName mid)
checkCaseAlts :: CaseType -> [Alt ()] -> WCM ()
checkCaseAlts _ [] = ok
checkCaseAlts ct alts@(Alt p _ _ : _) = do
let pats = map (\(Alt _ pat _) -> [pat]) alts
(nonExhaustive, overlapped, nondet) <- checkPatternMatching pats
case ct of
Flex -> do
unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
warnMissingPattern p "an fcase alternative" nonExhaustive
when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report
$ warnNondetOverlapping p "An fcase expression"
Rigid -> do
unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $
warnMissingPattern p "a case alternative" nonExhaustive
unless (null overlapped) $ warnFor WarnOverlapping $ report $
warnUnreachablePattern p overlapped
checkPatternMatching :: [[Pattern ()]]
-> WCM ([ExhaustivePats], [[Pattern ()]], Bool)
checkPatternMatching pats = do
simplePats <- mapM (mapM simplifyPat) pats
(missing, used, nondet) <- processEqs (zip [1..] simplePats)
nonExhaustive <- mapM tidyExhaustivePats missing
let overlap = [ eqn | (i, eqn) <- zip [1..] pats, i `IntSet.notMember` used]
return (nonExhaustive , overlap, nondet)
simplifyPat :: Pattern () -> WCM (Pattern ())
simplifyPat p@(LiteralPattern _ l) = return $ case l of
String s -> simplifyListPattern $ map (LiteralPattern () . Char) s
_ -> p
simplifyPat (NegativePattern a l) = return $ LiteralPattern a (negateLit l)
where
negateLit (Int n) = Int (n)
negateLit (Float d) = Float (d)
negateLit x = x
simplifyPat v@(VariablePattern _ _) = return v
simplifyPat (ConstructorPattern a c ps) =
ConstructorPattern a c `liftM` mapM simplifyPat ps
simplifyPat (InfixPattern a p1 c p2) =
ConstructorPattern a c `liftM` mapM simplifyPat [p1, p2]
simplifyPat (ParenPattern p) = simplifyPat p
simplifyPat (RecordPattern _ c fs) = do
(_, ls) <- getAllLabels c
let ps = map (getPattern (map field2Tuple fs)) ls
simplifyPat (ConstructorPattern () c ps)
where
getPattern fs' l' =
fromMaybe wildPat (lookup l' [(unqualify l, p) | (l, p) <- fs'])
simplifyPat (TuplePattern ps) =
ConstructorPattern () (qTupleId (length ps)) `liftM` mapM simplifyPat ps
simplifyPat (ListPattern _ ps) =
simplifyListPattern `liftM` mapM simplifyPat ps
simplifyPat (AsPattern _ p) = simplifyPat p
simplifyPat (LazyPattern _) = return wildPat
simplifyPat (FunctionPattern _ _ _) = return wildPat
simplifyPat (InfixFuncPattern _ _ _ _) = return wildPat
getAllLabels :: QualIdent -> WCM (QualIdent, [Ident])
getAllLabels c = do
tyEnv <- gets valueEnv
case qualLookupValue c tyEnv of
[DataConstructor qc _ ls _] -> return (qc, ls)
_ -> internalError $
"Checks.WarnCheck.getAllLabels: " ++ show c
simplifyListPattern :: [Pattern ()] -> Pattern ()
simplifyListPattern = foldr (\p1 p2 -> ConstructorPattern () qConsId [p1, p2])
(ConstructorPattern () qNilId [])
type EqnPats = [Pattern ()]
type EqnNo = Int
type EqnInfo = (EqnNo, EqnPats)
type ExhaustivePats = (EqnPats, [(Ident, [Literal])])
type EqnSet = IntSet.IntSet
processEqs :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processEqs [] = return ([], IntSet.empty, False)
processEqs eqs@((n, ps):_)
| null ps = return ([], IntSet.singleton n, length eqs > 1)
| any isLitPat firstPats = processLits eqs
| any isConPat firstPats = processCons eqs
| all isVarPat firstPats = processVars eqs
| otherwise = internalError "Checks.WarnCheck.processEqs"
where firstPats = map firstPat eqs
processLits :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processLits [] = error "WarnCheck.processLits"
processLits qs@(q:_) = do
(missing1, used1, nd1) <- processUsedLits usedLits qs
if null defaults
then return $ (defaultPat : missing1, used1, nd1)
else do
(missing2, used2, nd2) <- processEqs defaults
return ( [ (wildPat : ps, cs) | (ps, cs) <- missing2 ] ++ missing1
, IntSet.union used1 used2, nd1 || nd2 )
where
usedLits = nub $ concatMap (getLit . firstPat) qs
defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ]
defaultPat = ( VariablePattern () newVar :
replicate (length (snd q) 1) wildPat
, [(newVar, usedLits)]
)
newVar = mkIdent "x"
processUsedLits :: [Literal] -> [EqnInfo]
-> WCM ([ExhaustivePats], EqnSet, Bool)
processUsedLits lits qs = do
(eps, idxs, nds) <- unzip3 `liftM` mapM process lits
return (concat eps, IntSet.unions idxs, or nds)
where
process lit = do
let qs' = [shiftPat q | q <- qs, isVarLit lit (firstPat q)]
ovlp = length qs' > 1
(missing, used, nd) <- processEqs qs'
return ( map (\(xs, ys) -> (LiteralPattern () lit : xs, ys)) missing
, used
, nd && ovlp
)
processCons :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processCons [] = error "WarnCheck.processCons"
processCons qs@(q:_) = do
(missing1, used1, nd) <- processUsedCons used_cons qs
unused <- getUnusedCons (map fst used_cons)
if null unused
then return (missing1, used1, nd)
else if null defaults
then return $ (map defaultPat unused ++ missing1, used1, nd)
else do
(missing2, used2, nd2) <- processEqs defaults
return ( [ (mkPattern c : ps, cs) | c <- unused, (ps, cs) <- missing2 ]
++ missing1
, IntSet.union used1 used2, nd || nd2)
where
used_cons = nub $ concatMap (getCon . firstPat) qs
defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ]
defaultPat c = (mkPattern c : replicate (length (snd q) 1) wildPat, [])
mkPattern c = ConstructorPattern ()
(qualifyLike (fst $ head used_cons) (constrIdent c))
(replicate (length $ constrTypes c) wildPat)
processUsedCons :: [(QualIdent, Int)] -> [EqnInfo]
-> WCM ([ExhaustivePats], EqnSet, Bool)
processUsedCons cons qs = do
(eps, idxs, nds) <- unzip3 `liftM` mapM process cons
return (concat eps, IntSet.unions idxs, or nds)
where
process (c, a) = do
let qs' = [ removeFirstCon c a q | q <- qs , isVarCon c (firstPat q)]
ovlp = length qs' > 1
(missing, used, nd) <- processEqs qs'
return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd && ovlp)
makeCon c a ps = let (args, rest) = splitAt a ps
in ConstructorPattern () c args : rest
removeFirstCon c a (n, p:ps)
| isVarPat p = (n, replicate a wildPat ++ ps)
| isCon c p = (n, patArgs p ++ ps)
removeFirstCon _ _ _ = internalError "Checks.WarnCheck.removeFirstCon"
processVars :: [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processVars [] = error "WarnCheck.processVars"
processVars eqs@((n, _) : _) = do
let ovlp = length eqs > 1
(missing, used, nd) <- processEqs (map shiftPat eqs)
return ( map (\(xs, ys) -> (wildPat : xs, ys)) missing
, IntSet.insert n used, nd && ovlp)
getUnusedCons :: [QualIdent] -> WCM [DataConstr]
getUnusedCons [] = internalError "Checks.WarnCheck.getUnusedCons"
getUnusedCons qs@(q:_) = do
allCons <- getConTy q >>= getTyCons . rootOfType . arrowBase
return [c | c <- allCons, (constrIdent c) `notElem` map unqualify qs]
getConTy :: QualIdent -> WCM Type
getConTy q = do
tyEnv <- gets valueEnv
tcEnv <- gets tyConsEnv
case qualLookupValue q tyEnv of
[DataConstructor _ _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty
[NewtypeConstructor _ _ (ForAllExist _ _ (PredType _ ty))] -> return ty
_ -> case qualLookupTypeInfo q tcEnv of
[AliasType _ _ _ ty] -> return ty
_ -> internalError $ "Checks.WarnCheck.getConTy: " ++ show q
getTyCons :: QualIdent -> WCM [DataConstr]
getTyCons tc = do
tc' <- unAlias tc
tcEnv <- gets tyConsEnv
return $ case lookupTypeInfo (unqualify tc) tcEnv of
[DataType _ _ cs] -> cs
[RenamingType _ _ nc] -> [nc]
_ -> case qualLookupTypeInfo tc' tcEnv of
[DataType _ _ cs] -> cs
[RenamingType _ _ nc] -> [nc]
err -> internalError $ "Checks.WarnCheck.getTyCons: " ++
show tc ++ ' ' : show err ++ '\n' : show tcEnv
tidyExhaustivePats :: ExhaustivePats -> WCM ExhaustivePats
tidyExhaustivePats (xs, ys) = mapM tidyPat xs >>= \xs' -> return (xs', ys)
tidyPat :: Pattern () -> WCM (Pattern ())
tidyPat p@(LiteralPattern _ _) = return p
tidyPat p@(VariablePattern _ _) = return p
tidyPat p@(ConstructorPattern _ c ps)
| isQTupleId c =
TuplePattern `liftM` mapM tidyPat ps
| c == qConsId && isFiniteList p =
ListPattern () `liftM` mapM tidyPat (unwrapFinite p)
| c == qConsId = unwrapInfinite p
| otherwise =
ConstructorPattern () c `liftM` mapM tidyPat ps
where
isFiniteList (ConstructorPattern _ d [] ) = d == qNilId
isFiniteList (ConstructorPattern _ d [_, e2]) | d == qConsId = isFiniteList e2
isFiniteList _ = False
unwrapFinite (ConstructorPattern _ _ [] ) = []
unwrapFinite (ConstructorPattern _ _ [p1,p2]) = p1 : unwrapFinite p2
unwrapFinite pat
= internalError $ "WarnCheck.tidyPat.unwrapFinite: " ++ show pat
unwrapInfinite (ConstructorPattern a d [p1,p2]) =
liftM2 (flip (InfixPattern a) d) (tidyPat p1) (unwrapInfinite p2)
unwrapInfinite p0 = return p0
tidyPat p = internalError $ "Checks.WarnCheck.tidyPat: " ++ show p
firstPat :: EqnInfo -> Pattern ()
firstPat (_, [] ) = internalError "Checks.WarnCheck.firstPat: empty list"
firstPat (_, (p:_)) = p
shiftPat :: EqnInfo -> EqnInfo
shiftPat (_, [] ) = internalError "Checks.WarnCheck.shiftPat: empty list"
shiftPat (n, (_:ps)) = (n, ps)
wildPat :: Pattern ()
wildPat = VariablePattern () anonId
getLit :: Pattern a -> [Literal]
getLit (LiteralPattern _ l) = [l]
getLit _ = []
getCon :: Pattern a -> [(QualIdent, Int)]
getCon (ConstructorPattern _ c ps) = [(c, length ps)]
getCon _ = []
isVarLit :: Literal -> Pattern a -> Bool
isVarLit l p = isVarPat p || isLit l p
isVarCon :: QualIdent -> Pattern a -> Bool
isVarCon c p = isVarPat p || isCon c p
isCon :: QualIdent -> Pattern a -> Bool
isCon c (ConstructorPattern _ d _) = c == d
isCon _ _ = False
isLit :: Literal -> Pattern a -> Bool
isLit l (LiteralPattern _ m) = l == m
isLit _ _ = False
isLitPat :: Pattern a -> Bool
isLitPat (LiteralPattern _ _) = True
isLitPat _ = False
isVarPat :: Pattern a -> Bool
isVarPat (VariablePattern _ _) = True
isVarPat _ = False
isConPat :: Pattern a -> Bool
isConPat (ConstructorPattern _ _ _) = True
isConPat _ = False
patArgs :: Pattern a -> [Pattern a]
patArgs (ConstructorPattern _ _ ps) = ps
patArgs _ = []
warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern p loc pats = posMessage p
$ text "Pattern matches are non-exhaustive"
$+$ text "In" <+> text loc <> char ':'
$+$ nest 2 (text "Patterns not matched:" $+$ nest 2 (vcat (ppExPats pats)))
where
ppExPats ps
| length ps > maxPattern = ppPats ++ [text "..."]
| otherwise = ppPats
where ppPats = map ppExPat (take maxPattern ps)
ppExPat (ps, cs)
| null cs = ppPats
| otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs)
where ppPats = hsep (map (ppPattern 2) ps)
ppCons (i, lits) = ppIdent i <+> text "`notElem`"
<+> ppExpr 0 (List () (map (Literal ()) lits))
warnUnreachablePattern :: Position -> [[Pattern a]] -> Message
warnUnreachablePattern p pats = posMessage p
$ text "Pattern matches are unreachable"
$+$ text "In a case alternative:"
$+$ nest 2 (vcat (ppExPats pats) <+> text "->" <+> text "...")
where
ppExPats ps
| length ps > maxPattern = ppPats ++ [text "..."]
| otherwise = ppPats
where ppPats = map ppPat (take maxPattern ps)
ppPat ps = hsep (map (ppPattern 2) ps)
maxPattern :: Int
maxPattern = 4
warnNondetOverlapping :: Position -> String -> Message
warnNondetOverlapping p loc = posMessage p $
text loc <+> text "is potentially non-deterministic due to overlapping rules"
checkShadowing :: Ident -> WCM ()
checkShadowing x = warnFor WarnNameShadowing $
shadowsVar x >>= maybe ok (report . warnShadowing x)
checkTypeShadowing :: Ident -> WCM ()
checkTypeShadowing x = warnFor WarnNameShadowing $
shadowsTypeVar x >>= maybe ok (report . warnTypeShadowing x)
reportUnusedVars :: WCM ()
reportUnusedVars = reportAllUnusedVars WarnUnusedBindings
reportUnusedGlobalVars :: WCM ()
reportUnusedGlobalVars = reportAllUnusedVars WarnUnusedGlobalBindings
reportAllUnusedVars :: WarnFlag -> WCM ()
reportAllUnusedVars wFlag = warnFor wFlag $ do
unused <- returnUnrefVars
unless (null unused) $ mapM_ report $ map warnUnrefVar unused
reportUnusedTypeVars :: [Ident] -> WCM ()
reportUnusedTypeVars vs = warnFor WarnUnusedBindings $ do
unused <- filterM isUnrefTypeVar vs
unless (null unused) $ mapM_ report $ map warnUnrefTypeVar unused
insertDecl :: Decl a -> WCM ()
insertDecl (DataDecl _ d _ cs _) = do
insertTypeConsId d
mapM_ insertConstrDecl cs
insertDecl (ExternalDataDecl _ d _) = insertTypeConsId d
insertDecl (NewtypeDecl _ d _ nc _) = do
insertTypeConsId d
insertNewConstrDecl nc
insertDecl (TypeDecl _ t _ ty) = do
insertTypeConsId t
insertTypeExpr ty
insertDecl (FunctionDecl _ _ f _) = do
cons <- isConsId f
unless cons $ insertVar f
insertDecl (ExternalDecl _ vs) = mapM_ (insertVar . varIdent) vs
insertDecl (PatternDecl _ p _) = insertPattern False p
insertDecl (FreeDecl _ vs) = mapM_ (insertVar . varIdent) vs
insertDecl (ClassDecl _ _ cls _ ds) = do
insertTypeConsId cls
mapM_ insertVar $ concatMap methods ds
insertDecl _ = ok
insertTypeExpr :: TypeExpr -> WCM ()
insertTypeExpr (VariableType _) = ok
insertTypeExpr (ConstructorType _) = ok
insertTypeExpr (ApplyType ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]
insertTypeExpr (TupleType tys) = mapM_ insertTypeExpr tys
insertTypeExpr (ListType ty) = insertTypeExpr ty
insertTypeExpr (ArrowType ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]
insertTypeExpr (ParenType ty) = insertTypeExpr ty
insertTypeExpr (ForallType _ ty) = insertTypeExpr ty
insertConstrDecl :: ConstrDecl -> WCM ()
insertConstrDecl (ConstrDecl _ _ _ c _) = insertConsId c
insertConstrDecl (ConOpDecl _ _ _ _ op _) = insertConsId op
insertConstrDecl (RecordDecl _ _ _ c _) = insertConsId c
insertNewConstrDecl :: NewConstrDecl -> WCM ()
insertNewConstrDecl (NewConstrDecl _ c _) = insertConsId c
insertNewConstrDecl (NewRecordDecl _ c _) = insertConsId c
insertPattern :: Bool -> Pattern a -> WCM ()
insertPattern fp (VariablePattern _ v) = do
cons <- isConsId v
unless cons $ do
var <- isVarId v
if and [fp, var, not (isAnonId v)] then visitId v else insertVar v
insertPattern fp (ConstructorPattern _ c ps) = do
cons <- isQualConsId c
mapM_ (insertPattern (not cons || fp)) ps
insertPattern fp (InfixPattern a p1 c p2)
= insertPattern fp (ConstructorPattern a c [p1, p2])
insertPattern fp (ParenPattern p) = insertPattern fp p
insertPattern fp (RecordPattern _ _ fs) = mapM_ (insertFieldPattern fp) fs
insertPattern fp (TuplePattern ps) = mapM_ (insertPattern fp) ps
insertPattern fp (ListPattern _ ps) = mapM_ (insertPattern fp) ps
insertPattern fp (AsPattern v p) = insertVar v >> insertPattern fp p
insertPattern fp (LazyPattern p) = insertPattern fp p
insertPattern _ (FunctionPattern _ f ps) = do
visitQId f
mapM_ (insertPattern True) ps
insertPattern _ (InfixFuncPattern a p1 f p2)
= insertPattern True (FunctionPattern a f [p1, p2])
insertPattern _ _ = ok
insertFieldPattern :: Bool -> Field (Pattern a) -> WCM ()
insertFieldPattern fp (Field _ _ p) = insertPattern fp p
data IdInfo
= ConsInfo
| VarInfo Ident Bool
deriving Show
isVariable :: IdInfo -> Bool
isVariable (VarInfo _ _) = True
isVariable _ = False
getVariable :: IdInfo -> Maybe Ident
getVariable (VarInfo v _) = Just v
getVariable _ = Nothing
isConstructor :: IdInfo -> Bool
isConstructor ConsInfo = True
isConstructor _ = False
variableVisited :: IdInfo -> Bool
variableVisited (VarInfo _ v) = v
variableVisited _ = True
visitVariable :: IdInfo -> IdInfo
visitVariable (VarInfo v _) = VarInfo v True
visitVariable info = info
insertScope :: QualIdent -> IdInfo -> WCM ()
insertScope qid info = modifyScope $ qualBindNestEnv qid info
insertVar :: Ident -> WCM ()
insertVar v = unless (isAnonId v) $ do
known <- isKnownVar v
if known then visitId v else insertScope (commonId v) (VarInfo v False)
insertTypeVar :: Ident -> WCM ()
insertTypeVar v = unless (isAnonId v)
$ insertScope (typeId v) (VarInfo v False)
insertConsId :: Ident -> WCM ()
insertConsId c = insertScope (commonId c) ConsInfo
insertTypeConsId :: Ident -> WCM ()
insertTypeConsId c = insertScope (typeId c) ConsInfo
isVarId :: Ident -> WCM Bool
isVarId v = gets (isVar $ commonId v)
isConsId :: Ident -> WCM Bool
isConsId c = gets (isCons $ qualify c)
isQualConsId :: QualIdent -> WCM Bool
isQualConsId qid = gets (isCons qid)
shadows :: QualIdent -> WcState -> Maybe Ident
shadows qid s = do
guard $ not (qualInLocalNestEnv qid sc)
info <- listToMaybe $ qualLookupNestEnv qid sc
getVariable info
where sc = scope s
shadowsVar :: Ident -> WCM (Maybe Ident)
shadowsVar v = gets (shadows $ commonId v)
shadowsTypeVar :: Ident -> WCM (Maybe Ident)
shadowsTypeVar v = gets (shadows $ typeId v)
visitId :: Ident -> WCM ()
visitId v = modifyScope (qualModifyNestEnv visitVariable (commonId v))
visitQId :: QualIdent -> WCM ()
visitQId v = do
mid <- getModuleIdent
maybe ok visitId (localIdent mid v)
visitTypeId :: Ident -> WCM ()
visitTypeId v = modifyScope (qualModifyNestEnv visitVariable (typeId v))
visitQTypeId :: QualIdent -> WCM ()
visitQTypeId v = do
mid <- getModuleIdent
maybe ok visitTypeId (localIdent mid v)
isKnownVar :: Ident -> WCM Bool
isKnownVar v = gets $ \s -> isKnown s (commonId v)
isUnrefTypeVar :: Ident -> WCM Bool
isUnrefTypeVar v = gets (\s -> isUnref s (typeId v))
returnUnrefVars :: WCM [Ident]
returnUnrefVars = gets (\s ->
let ids = map fst (localNestEnv (scope s))
unrefs = filter (isUnref s . qualify) ids
in unrefs )
inNestedScope :: WCM a -> WCM ()
inNestedScope m = beginScope >> m >> endScope
beginScope :: WCM ()
beginScope = modifyScope nestEnv
endScope :: WCM ()
endScope = modifyScope unnestEnv
isKnown :: WcState -> QualIdent -> Bool
isKnown s qid = qualInLocalNestEnv qid (scope s)
isUnref :: WcState -> QualIdent -> Bool
isUnref s qid = let sc = scope s
in (any (not . variableVisited) (qualLookupNestEnv qid sc))
&& qualInLocalNestEnv qid sc
isVar :: QualIdent -> WcState -> Bool
isVar qid s = maybe (isAnonId (unqualify qid))
isVariable
(listToMaybe (qualLookupNestEnv qid (scope s)))
isCons :: QualIdent -> WcState -> Bool
isCons qid s = maybe (isImportedCons s qid)
isConstructor
(listToMaybe (qualLookupNestEnv qid (scope s)))
where isImportedCons s' qid' = case qualLookupValue qid' (valueEnv s') of
(DataConstructor _ _ _ _) : _ -> True
(NewtypeConstructor _ _ _) : _ -> True
_ -> False
commonId :: Ident -> QualIdent
commonId = qualify . unRenameIdent
typeId :: Ident -> QualIdent
typeId = qualify . flip renameIdent 1
checkCaseMode :: [Decl a] -> WCM ()
checkCaseMode = warnFor WarnIrregularCaseMode . mapM_ checkCaseModeDecl
checkCaseModeDecl :: Decl a -> WCM ()
checkCaseModeDecl (DataDecl _ tc vs cs _) = do
checkCaseModeID isDataDeclName tc
mapM_ (checkCaseModeID isVarName) vs
mapM_ checkCaseModeConstr cs
checkCaseModeDecl (NewtypeDecl _ tc vs nc _) = do
checkCaseModeID isDataDeclName tc
mapM_ (checkCaseModeID isVarName) vs
checkCaseModeNewConstr nc
checkCaseModeDecl (TypeDecl _ tc vs ty) = do
checkCaseModeID isDataDeclName tc
mapM_ (checkCaseModeID isVarName) vs
checkCaseModeTypeExpr ty
checkCaseModeDecl (TypeSig _ fs qty) = do
mapM_ (checkCaseModeID isFuncName) fs
checkCaseModeQualTypeExpr qty
checkCaseModeDecl (FunctionDecl _ _ f eqs) = do
checkCaseModeID isFuncName f
mapM_ checkCaseModeEquation eqs
checkCaseModeDecl (ExternalDecl _ vs) =
mapM_ (checkCaseModeID isFuncName . varIdent) vs
checkCaseModeDecl (PatternDecl _ t rhs) = do
checkCaseModePattern t
checkCaseModeRhs rhs
checkCaseModeDecl (FreeDecl _ vs) =
mapM_ (checkCaseModeID isVarName . varIdent) vs
checkCaseModeDecl (DefaultDecl _ tys) = mapM_ checkTypeExpr tys
checkCaseModeDecl (ClassDecl _ cx cls tv ds) = do
checkCaseModeContext cx
checkCaseModeID isClassDeclName cls
checkCaseModeID isVarName tv
mapM_ checkCaseModeDecl ds
checkCaseModeDecl (InstanceDecl _ cx _ inst ds) = do
checkCaseModeContext cx
checkCaseModeTypeExpr inst
mapM_ checkCaseModeDecl ds
checkCaseModeDecl _ = ok
checkCaseModeConstr :: ConstrDecl -> WCM ()
checkCaseModeConstr (ConstrDecl _ evs cx c tys) = do
mapM_ (checkCaseModeID isVarName) evs
checkCaseModeContext cx
checkCaseModeID isConstrName c
mapM_ checkCaseModeTypeExpr tys
checkCaseModeConstr (ConOpDecl _ evs cx ty1 c ty2) = do
mapM_ (checkCaseModeID isVarName) evs
checkCaseModeContext cx
checkCaseModeTypeExpr ty1
checkCaseModeID isConstrName c
checkCaseModeTypeExpr ty2
checkCaseModeConstr (RecordDecl _ evs cx c fs) = do
mapM_ (checkCaseModeID isVarName) evs
checkCaseModeContext cx
checkCaseModeID isConstrName c
mapM_ checkCaseModeFieldDecl fs
checkCaseModeFieldDecl :: FieldDecl -> WCM ()
checkCaseModeFieldDecl (FieldDecl _ fs ty) = do
mapM_ (checkCaseModeID isFuncName) fs
checkCaseModeTypeExpr ty
checkCaseModeNewConstr :: NewConstrDecl -> WCM ()
checkCaseModeNewConstr (NewConstrDecl _ nc ty) = do
checkCaseModeID isConstrName nc
checkCaseModeTypeExpr ty
checkCaseModeNewConstr (NewRecordDecl _ nc (f, ty)) = do
checkCaseModeID isConstrName nc
checkCaseModeID isFuncName f
checkCaseModeTypeExpr ty
checkCaseModeContext :: Context -> WCM ()
checkCaseModeContext = mapM_ checkCaseModeConstraint
checkCaseModeConstraint :: Constraint -> WCM ()
checkCaseModeConstraint (Constraint _ ty) = checkCaseModeTypeExpr ty
checkCaseModeTypeExpr :: TypeExpr -> WCM ()
checkCaseModeTypeExpr (ApplyType ty1 ty2) = do
checkCaseModeTypeExpr ty1
checkCaseModeTypeExpr ty2
checkCaseModeTypeExpr (VariableType tv) = checkCaseModeID isVarName tv
checkCaseModeTypeExpr (TupleType tys) = mapM_ checkCaseModeTypeExpr tys
checkCaseModeTypeExpr (ListType ty) = checkCaseModeTypeExpr ty
checkCaseModeTypeExpr (ArrowType ty1 ty2) = do
checkCaseModeTypeExpr ty1
checkCaseModeTypeExpr ty2
checkCaseModeTypeExpr (ParenType ty) = checkCaseModeTypeExpr ty
checkCaseModeTypeExpr (ForallType tvs ty) = do
mapM_ (checkCaseModeID isVarName) tvs
checkCaseModeTypeExpr ty
checkCaseModeTypeExpr _ = ok
checkCaseModeQualTypeExpr :: QualTypeExpr -> WCM ()
checkCaseModeQualTypeExpr (QualTypeExpr cx ty) = do
checkCaseModeContext cx
checkCaseModeTypeExpr ty
checkCaseModeEquation :: Equation a -> WCM ()
checkCaseModeEquation (Equation _ lhs rhs) = do
checkCaseModeLhs lhs
checkCaseModeRhs rhs
checkCaseModeLhs :: Lhs a -> WCM ()
checkCaseModeLhs (FunLhs f ts) = do
checkCaseModeID isFuncName f
mapM_ checkCaseModePattern ts
checkCaseModeLhs (OpLhs t1 f t2) = do
checkCaseModePattern t1
checkCaseModeID isFuncName f
checkCaseModePattern t2
checkCaseModeLhs (ApLhs lhs ts) = do
checkCaseModeLhs lhs
mapM_ checkCaseModePattern ts
checkCaseModeRhs :: Rhs a -> WCM ()
checkCaseModeRhs (SimpleRhs _ e ds) = do
checkCaseModeExpr e
mapM_ checkCaseModeDecl ds
checkCaseModeRhs (GuardedRhs es ds) = do
mapM_ checkCaseModeCondExpr es
mapM_ checkCaseModeDecl ds
checkCaseModeCondExpr :: CondExpr a -> WCM ()
checkCaseModeCondExpr (CondExpr _ g e) = do
checkCaseModeExpr g
checkCaseModeExpr e
checkCaseModePattern :: Pattern a -> WCM ()
checkCaseModePattern (VariablePattern _ v) = checkCaseModeID isVarName v
checkCaseModePattern (ConstructorPattern _ _ ts) = mapM_ checkCaseModePattern ts
checkCaseModePattern (InfixPattern _ t1 _ t2) = do
checkCaseModePattern t1
checkCaseModePattern t2
checkCaseModePattern (ParenPattern t) = checkCaseModePattern t
checkCaseModePattern (RecordPattern _ _ fs) = mapM_ checkCaseModeFieldPattern fs
checkCaseModePattern (TuplePattern ts) = mapM_ checkCaseModePattern ts
checkCaseModePattern (ListPattern _ ts) = mapM_ checkCaseModePattern ts
checkCaseModePattern (AsPattern v t) = do
checkCaseModeID isVarName v
checkCaseModePattern t
checkCaseModePattern (LazyPattern t) = checkCaseModePattern t
checkCaseModePattern (FunctionPattern _ _ ts) = mapM_ checkCaseModePattern ts
checkCaseModePattern (InfixFuncPattern _ t1 _ t2) = do
checkCaseModePattern t1
checkCaseModePattern t2
checkCaseModePattern _ = ok
checkCaseModeExpr :: Expression a -> WCM ()
checkCaseModeExpr (Paren e) = checkCaseModeExpr e
checkCaseModeExpr (Typed e qty) = do
checkCaseModeExpr e
checkCaseModeQualTypeExpr qty
checkCaseModeExpr (Record _ _ fs) = mapM_ checkCaseModeFieldExpr fs
checkCaseModeExpr (RecordUpdate e fs) = do
checkCaseModeExpr e
mapM_ checkCaseModeFieldExpr fs
checkCaseModeExpr (Tuple es) = mapM_ checkCaseModeExpr es
checkCaseModeExpr (List _ es) = mapM_ checkCaseModeExpr es
checkCaseModeExpr (ListCompr e stms) = do
checkCaseModeExpr e
mapM_ checkCaseModeStatement stms
checkCaseModeExpr (EnumFrom e) = checkCaseModeExpr e
checkCaseModeExpr (EnumFromThen e1 e2) = do
checkCaseModeExpr e1
checkCaseModeExpr e2
checkCaseModeExpr (EnumFromTo e1 e2) = do
checkCaseModeExpr e1
checkCaseModeExpr e2
checkCaseModeExpr (EnumFromThenTo e1 e2 e3) = do
checkCaseModeExpr e1
checkCaseModeExpr e2
checkCaseModeExpr e3
checkCaseModeExpr (UnaryMinus e) = checkCaseModeExpr e
checkCaseModeExpr (Apply e1 e2) = do
checkCaseModeExpr e1
checkCaseModeExpr e2
checkCaseModeExpr (InfixApply e1 _ e2) = do
checkCaseModeExpr e1
checkCaseModeExpr e2
checkCaseModeExpr (LeftSection e _) = checkCaseModeExpr e
checkCaseModeExpr (RightSection _ e) = checkCaseModeExpr e
checkCaseModeExpr (Lambda ts e) = do
mapM_ checkCaseModePattern ts
checkCaseModeExpr e
checkCaseModeExpr (Let ds e) = do
mapM_ checkCaseModeDecl ds
checkCaseModeExpr e
checkCaseModeExpr (Do stms e) = do
mapM_ checkCaseModeStatement stms
checkCaseModeExpr e
checkCaseModeExpr (IfThenElse e1 e2 e3) = do
checkCaseModeExpr e1
checkCaseModeExpr e2
checkCaseModeExpr e3
checkCaseModeExpr (Case _ e as) = do
mapM_ checkCaseModeAlt as
checkCaseModeExpr e
checkCaseModeExpr _ = ok
checkCaseModeStatement :: Statement a -> WCM ()
checkCaseModeStatement (StmtExpr e) = checkCaseModeExpr e
checkCaseModeStatement (StmtDecl ds) = mapM_ checkCaseModeDecl ds
checkCaseModeStatement (StmtBind t e) = do
checkCaseModePattern t
checkCaseModeExpr e
checkCaseModeAlt :: Alt a -> WCM ()
checkCaseModeAlt (Alt _ t rhs) = checkCaseModePattern t >> checkCaseModeRhs rhs
checkCaseModeFieldPattern :: Field (Pattern a) -> WCM ()
checkCaseModeFieldPattern (Field _ _ t) = checkCaseModePattern t
checkCaseModeFieldExpr :: Field (Expression a) -> WCM ()
checkCaseModeFieldExpr (Field _ _ e) = checkCaseModeExpr e
checkCaseModeID :: (CaseMode -> String -> Bool) -> Ident -> WCM ()
checkCaseModeID f i@(Ident _ name _) = do
c <- gets caseMode
unless (f c name) (report $ warnCaseMode i c)
isVarName :: CaseMode -> String -> Bool
isVarName CaseModeProlog (x:_) | isAlpha x = isUpper x
isVarName CaseModeGoedel (x:_) | isAlpha x = isLower x
isVarName CaseModeHaskell (x:_) | isAlpha x = isLower x
isVarName _ _ = True
isFuncName :: CaseMode -> String -> Bool
isFuncName CaseModeHaskell (x:_) | isAlpha x = isLower x
isFuncName CaseModeGoedel (x:_) | isAlpha x = isUpper x
isFuncName CaseModeProlog (x:_) | isAlpha x = isLower x
isFuncName _ _ = True
isConstrName :: CaseMode -> String -> Bool
isConstrName = isDataDeclName
isClassDeclName :: CaseMode -> String -> Bool
isClassDeclName = isDataDeclName
isDataDeclName :: CaseMode -> String -> Bool
isDataDeclName CaseModeProlog (x:_) | isAlpha x = isLower x
isDataDeclName CaseModeGoedel (x:_) | isAlpha x = isUpper x
isDataDeclName CaseModeHaskell (x:_) | isAlpha x = isUpper x
isDataDeclName _ _ = True
warnCaseMode :: Ident -> CaseMode -> Message
warnCaseMode i@(Ident _ name _ ) c = posMessage i $
text "Wrong case mode in symbol" <+> text (escName i) <+>
text "due to selected case mode" <+> text (escapeCaseMode c) <> comma <+>
text "try renaming to" <+> text (caseSuggestion name) <+> text "instead"
caseSuggestion :: String -> String
caseSuggestion (x:xs) | isLower x = (toUpper x : xs)
| isUpper x = (toLower x : xs)
caseSuggestion _ = internalError
"Checks.WarnCheck.caseSuggestion: Identifier starts with illegal Symbol"
escapeCaseMode :: CaseMode -> String
escapeCaseMode CaseModeFree = "`free`"
escapeCaseMode CaseModeHaskell = "`haskell`"
escapeCaseMode CaseModeProlog = "`prolog`"
escapeCaseMode CaseModeGoedel = "`goedel`"
warnUnrefTypeVar :: Ident -> Message
warnUnrefTypeVar v = posMessage v $ hsep $ map text
[ "Unreferenced type variable", escName v ]
warnUnrefVar :: Ident -> Message
warnUnrefVar v = posMessage v $ hsep $ map text
[ "Unused declaration of variable", escName v ]
warnShadowing :: Ident -> Ident -> Message
warnShadowing x v = posMessage x $
text "Shadowing symbol" <+> text (escName x)
<> comma <+> text "bound at:" <+> ppPosition (getPosition v)
warnTypeShadowing :: Ident -> Ident -> Message
warnTypeShadowing x v = posMessage x $
text "Shadowing type variable" <+> text (escName x)
<> comma <+> text "bound at:" <+> ppPosition (getPosition v)