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