{- |
    Module      :  $Header$
    Description :  Checks for irregular code
    Copyright   :  (c) 2006        Martin Engelke
                       2011 - 2014 Björn Peemöller
                       2014 - 2015 Jan Tikovsky
                       2016 - 2017 Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module searches for potentially irregular code and generates
    warning messages.
-}
{-# LANGUAGE CPP #-}
module Checks.WarnCheck (warnCheck) where

#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

import           Control.Monad
  (filterM, foldM_, guard, liftM, liftM2, when, unless)
import           Control.Monad.State.Strict    (State, execState, gets, modify)
import qualified Data.IntSet         as IntSet
  (IntSet, empty, insert, notMember, singleton, union, unions)
import qualified Data.Map            as Map    (empty, insert, lookup)
import           Data.Maybe
  (catMaybes, fromMaybe, listToMaybe)
import           Data.List
  ((\\), intersect, intersectBy, nub, sort, unionBy)
import           Data.Char
  (isLower, isUpper, toLower, toUpper, isAlpha)

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent)

import Base.CurryTypes (ppTypeScheme)
import Base.Messages   (Message, posMessage, internalError)
import Base.NestEnv    ( NestEnv, emptyEnv, localNestEnv, nestEnv, unnestEnv
                       , qualBindNestEnv, qualInLocalNestEnv, qualLookupNestEnv
                       , qualModifyNestEnv)

import Base.Types
import Base.Utils (findMultiples)
import Env.ModuleAlias
import Env.Class (ClassEnv, classMethods, hasDefaultImpl)
import Env.TypeConstructor ( TCEnv, TypeInfo (..), lookupTypeInfo
                           , qualLookupTypeInfo, getOrigName )
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)

import CompilerOpts

-- Find potentially incorrect code in a Curry program and generate warnings
-- for the following issues:
--   - multiply imported modules, multiply imported/hidden values
--   - unreferenced variables
--   - shadowing variables
--   - idle case alternatives
--   - overlapping case alternatives
--   - non-adjacent function rules
--   - wrong case mode
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
  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

-- Current state of generating warnings
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]
  }

-- The monadic representation of the state allows the usage of monadic
-- syntax (do expression) for dealing easier and safer with its
-- contents.
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 ()

-- |Run a 'WCM' action and return the list of messages
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
-- ---------------------------------------------------------------------------

checkExports :: Maybe ExportSpec -> WCM () -- TODO checks
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
-- ---------------------------------------------------------------------------

-- Check import declarations for multiply imported modules and multiply
-- imported/hidden values.
-- The function uses a map of the already imported or hidden entities to
-- collect the entities throughout multiple import statements.
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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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
-- ---------------------------------------------------------------------------

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

-- ---------------------------------------------------------------------------
-- Find function rules which are disjoined
-- ---------------------------------------------------------------------------

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 p. HasPosition p => p -> Doc -> Message
posMessage 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

--TODO: shadowing und context etc.
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

-- Checks locally declared identifiers (i.e. functions and logic variables)
-- for shadowing
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
  (nonExhaustive :: [ExhaustivePats]
nonExhaustive, overlapped :: [[Pattern ()]]
overlapped, nondet :: Bool
nondet) <- [[Pattern ()]] -> WCM ([ExhaustivePats], [[Pattern ()]], Bool)
checkPatternMatching [[Pattern ()]]
pats
  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
$
    Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern Position
p ("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 ([[Pattern ()]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Pattern ()]]
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
$
    Position -> String -> Message
warnNondetOverlapping Position
p ("Function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
f)
  where p :: Position
p = SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
spi

-- Check an equation for warnings.
-- This is done in a seperate scope as the left-hand-side may introduce
-- new variables.
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

-- Check the right-hand-side of an equation.
-- Because local declarations may introduce new variables, we need
-- another scope nesting.
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          _ 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
  CaseType -> [Alt ()] -> WCM ()
checkCaseAlts 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

-- -----------------------------------------------------------------------------
-- Check for orphan instances
-- -----------------------------------------------------------------------------

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
$
    Position -> Doc -> Message
warnOrphanInstance (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
p) (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ Decl Any -> Doc
forall a. Decl a -> Doc
ppDecl (Decl Any -> Doc) -> Decl Any -> Doc
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Context -> QualIdent -> TypeExpr -> [Decl Any] -> Decl Any
forall a.
SpanInfo -> Context -> QualIdent -> TypeExpr -> [Decl a] -> Decl a
InstanceDecl SpanInfo
p Context
cx QualIdent
cls TypeExpr
ty []
  where tc :: QualIdent
tc = TypeExpr -> QualIdent
typeConstr TypeExpr
ty

warnOrphanInstance :: Position -> Doc -> Message
warnOrphanInstance :: Position -> Doc -> Message
warnOrphanInstance p :: Position
p doc :: Doc
doc = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Orphan instance:" Doc -> Doc -> Doc
<+> Doc
doc

-- -----------------------------------------------------------------------------
-- Check for missing method implementations
-- -----------------------------------------------------------------------------

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
. Position -> Ident -> Message
warnMissingMethodImplementation (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos 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 :: Position -> Ident -> Message
warnMissingMethodImplementation :: Position -> Ident -> Message
warnMissingMethodImplementation p :: Position
p f :: Ident
f = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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]

-- -----------------------------------------------------------------------------
-- Check for missing type signatures
-- -----------------------------------------------------------------------------

-- |Check if every top-level function has an accompanying type signature.
-- For external function declarations, this check is already performed
-- during syntax checking.
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 p. HasPosition p => p -> Doc -> Message
posMessage 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
  ]

-- -----------------------------------------------------------------------------
-- Check for overlapping module alias names
-- -----------------------------------------------------------------------------

-- check if module aliases in import declarations overlap with the module name
-- or another module alias

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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage ([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)

-- -----------------------------------------------------------------------------
-- Check for overlapping/unreachable and non-exhaustive case alternatives
-- -----------------------------------------------------------------------------

checkCaseAlts :: CaseType -> [Alt ()] -> WCM ()
checkCaseAlts :: CaseType -> [Alt ()] -> WCM ()
checkCaseAlts _  []                   = WCM ()
ok
checkCaseAlts ct :: CaseType
ct alts :: [Alt ()]
alts@(Alt spi :: SpanInfo
spi _ _ : _) = do
  let pats :: [[Pattern ()]]
pats = (Alt () -> [Pattern ()]) -> [Alt ()] -> [[Pattern ()]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Alt _ pat :: Pattern ()
pat _) -> [Pattern ()
pat]) [Alt ()]
alts
  (nonExhaustive :: [ExhaustivePats]
nonExhaustive, overlapped :: [[Pattern ()]]
overlapped, nondet :: Bool
nondet) <- [[Pattern ()]] -> WCM ([ExhaustivePats], [[Pattern ()]], Bool)
checkPatternMatching [[Pattern ()]]
pats
  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
$
        Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern Position
p "an fcase alternative" [ExhaustivePats]
nonExhaustive
      Bool -> WCM () -> WCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
nondet Bool -> Bool -> Bool
|| Bool -> Bool
not ([[Pattern ()]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Pattern ()]]
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
$ Position -> String -> Message
warnNondetOverlapping Position
p "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
$
        Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern Position
p "a case alternative" [ExhaustivePats]
nonExhaustive
      Bool -> WCM () -> WCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Pattern ()]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Pattern ()]]
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
$
        Position -> [[Pattern ()]] -> Message
forall a. Position -> [[Pattern a]] -> Message
warnUnreachablePattern Position
p [[Pattern ()]]
overlapped
  where p :: Position
p = SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
spi

-- -----------------------------------------------------------------------------
-- Check for non-exhaustive and overlapping patterns.
-- For an example, consider the following function definition:
-- @
-- f [True]    = 0
-- f (False:_) = 1
-- @
-- In this declaration, the following patterns are not matched:
-- @
-- [] _
-- (True:_:_)
-- @
-- This is identified and reported by the following code,, both for pattern
-- matching in function declarations and (f)case expressions.
-- -----------------------------------------------------------------------------

checkPatternMatching :: [[Pattern ()]]
                     -> WCM ([ExhaustivePats], [[Pattern ()]], Bool)
checkPatternMatching :: [[Pattern ()]] -> WCM ([ExhaustivePats], [[Pattern ()]], Bool)
checkPatternMatching pats :: [[Pattern ()]]
pats = do
  -- 1. We simplify the patterns by removing syntactic sugar temporarily
  --    for a simpler implementation.
  [[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
  -- 2. We compute missing and used pattern matching alternatives
  (missing :: [ExhaustivePats]
missing, used :: EqnSet
used, nondet :: Bool
nondet) <- [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processEqs ([Int] -> [[Pattern ()]] -> [EqnInfo]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [[Pattern ()]]
simplePats)
  -- 3. If any, we report the missing patterns, whereby we re-add the syntactic
  --    sugar removed in step (1) for a more precise output.
  [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 :: [[Pattern ()]]
overlap = [ [Pattern ()]
eqn | (i :: Int
i, eqn :: [Pattern ()]
eqn) <- [Int] -> [[Pattern ()]] -> [EqnInfo]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [[Pattern ()]]
pats, Int
i Int -> EqnSet -> Bool
`IntSet.notMember` EqnSet
used]
  ([ExhaustivePats], [[Pattern ()]], Bool)
-> WCM ([ExhaustivePats], [[Pattern ()]], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ExhaustivePats]
nonExhaustive , [[Pattern ()]]
overlap, Bool
nondet)

-- |Simplify a 'Pattern' until it only consists of
--   * Variables
--   * Integer, Float or Char literals
--   * Constructors
-- All other patterns like as-patterns, list patterns and alike are desugared.
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

-- |Create a simplified list pattern by applying @:@ and @[]@.
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 [])

-- |'ExhaustivePats' describes those pattern missing for an exhaustive
-- pattern matching, where a value can be thought of as a missing equation.
-- The first component contains the unmatched patterns, while the second
-- pattern contains an identifier and the literals matched for this identifier.
--
-- This is necessary when checking literal patterns because of the sheer
-- number of possible patterns. Missing literals are therefore converted
-- into the form @ ... x ... with x `notElem` [l1, ..., ln]@.
type EqnPats = [Pattern ()]
type EqnNo   = Int
type EqnInfo = (EqnNo, EqnPats)

type ExhaustivePats = (EqnPats, [(Ident, [Literal])])
type EqnSet  = IntSet.IntSet

-- |Compute the missing pattern by inspecting the first patterns and
-- categorize them as literal, constructor or variable patterns.
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):_)
  | [Pattern ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern ()]
ps                    = ([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)
  | (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

-- |Literal patterns are checked by extracting the matched literals
--  and constructing a pattern for any missing case.
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
  -- Check any patterns starting with the literals used
  (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
      -- Missing patterns for the default alternatives
      (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
  -- The literals occurring in the patterns
  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
  -- default alternatives (variable pattern)
  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') ]
  -- Pattern for all non-matched literals
  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. (a, b) -> b
snd 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"

-- |Construct exhaustive patterns starting with the used literals
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
           )

-- |Constructor patterns are checked by extracting the matched constructors
--  and constructing a pattern for any missing case.
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
  -- Compute any missing patterns starting with the used constructors
  (missing1 :: [ExhaustivePats]
missing1, used1 :: EqnSet
used1, nd :: Bool
nd) <- [(QualIdent, Int)]
-> [EqnInfo] -> WCM ([ExhaustivePats], EqnSet, Bool)
processUsedCons [(QualIdent, Int)]
used_cons [EqnInfo]
qs
  -- Determine unused constructors
  [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
        -- Missing patterns for the default alternatives
        (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 constructors (occurring in a pattern)
  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
  -- default alternatives (variable pattern)
  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') ]
  -- Pattern for a non-matched constructors
  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. (a, b) -> b
snd 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)

-- |Construct exhaustive patterns starting with the used constructors
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.
QualIdent -> Int -> (a, [Pattern ()]) -> (a, [Pattern ()])
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 ()]) -> (a, [Pattern ()])
removeFirstCon c :: QualIdent
c a :: Int
a (n :: a
n, p :: Pattern ()
p:ps :: [Pattern ()]
ps)
    | 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)
    | 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)
  removeFirstCon _ _ _ = String -> (a, [Pattern ()])
forall a. String -> a
internalError "Checks.WarnCheck.removeFirstCon"

-- |Variable patterns are exhaustive, so they are checked by simply
-- checking the following patterns.
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)

-- |Return the constructors of a type not contained in the list of constructors.
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]

-- |Retrieve the type of a given constructor.
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

-- |Retrieve all constructors of a given type.
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
  [DataConstr] -> WCM [DataConstr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataConstr] -> WCM [DataConstr])
-> [DataConstr] -> WCM [DataConstr]
forall a b. (a -> b) -> a -> b
$ case Ident -> TCEnv -> [TypeInfo]
lookupTypeInfo (QualIdent -> Ident
unqualify QualIdent
tc) TCEnv
tcEnv of
    [DataType     _ _ cs :: [DataConstr]
cs] -> [DataConstr]
cs
    [RenamingType _ _ nc :: DataConstr
nc] -> [DataConstr
nc]
    _ -> case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc' TCEnv
tcEnv of
      [DataType     _ _ cs :: [DataConstr]
cs] -> [DataConstr]
cs
      [RenamingType _ _ nc :: DataConstr
nc] -> [DataConstr
nc]
      err :: [TypeInfo]
err -> String -> [DataConstr]
forall a. String -> a
internalError (String -> [DataConstr]) -> 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]
err 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

-- |Resugar the exhaustive patterns previously desugared at 'simplifyPat'.
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)

-- |Resugar a pattern previously desugared at 'simplifyPat', i.e.
--   * Convert a tuple constructor pattern into a tuple pattern
--   * Convert a list constructor pattern representing a finite list
--     into a list pattern
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

-- |Get the first pattern of a list.
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

-- |Drop the first pattern of a list.
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)) = (Int
n, [Pattern ()]
ps)

-- |Wildcard pattern.
wildPat :: Pattern ()
wildPat :: Pattern ()
wildPat = SpanInfo -> () -> Ident -> Pattern ()
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo () Ident
anonId

-- |Retrieve any literal out of a pattern.
getLit :: Pattern a -> [Literal]
getLit :: Pattern a -> [Literal]
getLit (LiteralPattern _ _ l :: Literal
l) = [Literal
l]
getLit _                      = []

-- |Retrieve the constructor name and its arity for a pattern.
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 _                             = []

-- |Is a pattern a variable or literal pattern?
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

-- |Is a pattern a variable or a constructor pattern with the given constructor?
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

-- |Is a pattern a pattern matching for the given constructor?
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

-- |Is a pattern a pattern matching for the given literal?
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

-- |Is a pattern a literal pattern?
isLitPat :: Pattern a -> Bool
isLitPat :: Pattern a -> Bool
isLitPat (LiteralPattern  _ _ _) = Bool
True
isLitPat _                       = Bool
False

-- |Is a pattern a variable pattern?
isVarPat :: Pattern a -> Bool
isVarPat :: Pattern a -> Bool
isVarPat (VariablePattern _ _ _) = Bool
True
isVarPat _                       = Bool
False

-- |Is a pattern a constructor pattern?
isConPat :: Pattern a -> Bool
isConPat :: Pattern a -> Bool
isConPat (ConstructorPattern _ _ _ _) = Bool
True
isConPat _                            = Bool
False

-- |Retrieve the arguments of a pattern.
patArgs :: Pattern a -> [Pattern a]
patArgs :: Pattern a -> [Pattern a]
patArgs (ConstructorPattern _ _ _ ps :: [Pattern a]
ps) = [Pattern a]
ps
patArgs _                             = []

-- |Warning message for non-exhaustive patterns.
-- To shorten the output only the first 'maxPattern' are printed,
-- additional pattern are abbreviated by dots.
warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern :: Position -> String -> [ExhaustivePats] -> Message
warnMissingPattern p :: Position
p loc :: String
loc pats :: [ExhaustivePats]
pats = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p
  (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. [([Pattern a], [(Ident, [Literal])])] -> [Doc]
ppExPats [ExhaustivePats]
pats)))
  where
  ppExPats :: [([Pattern a], [(Ident, [Literal])])] -> [Doc]
ppExPats ps :: [([Pattern a], [(Ident, [Literal])])]
ps
    | [([Pattern a], [(Ident, [Literal])])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Pattern a], [(Ident, [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 = (([Pattern a], [(Ident, [Literal])]) -> Doc)
-> [([Pattern a], [(Ident, [Literal])])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Pattern a], [(Ident, [Literal])]) -> Doc
forall a. ([Pattern a], [(Ident, [Literal])]) -> Doc
ppExPat (Int
-> [([Pattern a], [(Ident, [Literal])])]
-> [([Pattern a], [(Ident, [Literal])])]
forall a. Int -> [a] -> [a]
take Int
maxPattern [([Pattern a], [(Ident, [Literal])])]
ps)
  ppExPat :: ([Pattern a], [(Ident, [Literal])]) -> Doc
ppExPat (ps :: [Pattern a]
ps, cs :: [(Ident, [Literal])]
cs)
    | [(Ident, [Literal])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, [Literal])]
cs   = Doc
ppPats
    | Bool
otherwise = Doc
ppPats Doc -> Doc -> Doc
<+> String -> Doc
text "with" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (((Ident, [Literal]) -> Doc) -> [(Ident, [Literal])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, [Literal]) -> Doc
ppCons [(Ident, [Literal])]
cs)
    where ppPats :: Doc
ppPats = [Doc] -> Doc
hsep ((Pattern a -> Doc) -> [Pattern a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 2) [Pattern a]
ps)
  ppCons :: (Ident, [Literal]) -> Doc
ppCons (i :: Ident
i, lits :: [Literal]
lits) = Ident -> Doc
ppIdent Ident
i Doc -> Doc -> Doc
<+> String -> Doc
text "`notElem`"
            Doc -> Doc -> Doc
<+> Int -> Expression () -> Doc
forall a. Int -> Expression a -> Doc
ppExpr 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))

-- |Warning message for unreachable patterns.
-- To shorten the output only the first 'maxPattern' are printed,
-- additional pattern are abbreviated by dots.
warnUnreachablePattern :: Position  -> [[Pattern a]] -> Message
warnUnreachablePattern :: Position -> [[Pattern a]] -> Message
warnUnreachablePattern p :: Position
p pats :: [[Pattern a]]
pats = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p
  (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 ([Doc] -> Doc
vcat ([[Pattern a]] -> [Doc]
forall a. [[Pattern a]] -> [Doc]
ppExPats [[Pattern a]]
pats) Doc -> Doc -> Doc
<+> String -> Doc
text "->" Doc -> Doc -> Doc
<+> String -> Doc
text "...")
  where
  ppExPats :: [[Pattern a]] -> [Doc]
ppExPats ps :: [[Pattern a]]
ps
    | [[Pattern a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Pattern a]]
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 = ([Pattern a] -> Doc) -> [[Pattern a]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Pattern a] -> Doc
forall a. [Pattern a] -> Doc
ppPat (Int -> [[Pattern a]] -> [[Pattern a]]
forall a. Int -> [a] -> [a]
take Int
maxPattern [[Pattern a]]
ps)
  ppPat :: [Pattern a] -> Doc
ppPat ps :: [Pattern a]
ps = [Doc] -> Doc
hsep ((Pattern a -> Doc) -> [Pattern a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pattern a -> Doc
forall a. Int -> Pattern a -> Doc
ppPattern 2) [Pattern a]
ps)

-- |Maximum number of missing patterns to be shown.
maxPattern :: Int
maxPattern :: Int
maxPattern = 4

warnNondetOverlapping :: Position -> String -> Message
warnNondetOverlapping :: Position -> String -> Message
warnNondetOverlapping p :: Position
p loc :: String
loc = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (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)

checkTypeShadowing :: Ident -> WCM ()
checkTypeShadowing :: Ident -> WCM ()
checkTypeShadowing x :: Ident
x = WarnFlag -> WCM () -> WCM ()
warnFor WarnFlag
WarnNameShadowing (WCM () -> WCM ()) -> WCM () -> WCM ()
forall a b. (a -> b) -> a -> b
$
  Ident -> WCM (Maybe Ident)
shadowsTypeVar 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
warnTypeShadowing 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

-- ---------------------------------------------------------------------------
-- For detecting unreferenced variables, the following functions update the
-- current check state by adding identifiers occuring in declaration left hand
-- sides.

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

-- 'fp' indicates whether 'checkPattern' deals with the arguments
-- of a function pattern or not.
-- Since function patterns are not recognized before syntax check, it is
-- necessary to determine whether a constructor pattern represents a
-- constructor or a function.
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 type for distinguishing identifiers as either (type) constructors or
-- (type) variables (including functions).
data IdInfo
  = ConsInfo           -- ^ Constructor
  | VarInfo Ident Bool -- ^ Variable with original definition (for position)
                       --   and used flag
  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)

shadowsTypeVar :: Ident -> WCM (Maybe Ident)
shadowsTypeVar :: Ident -> WCM (Maybe Ident)
shadowsTypeVar 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
typeId 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

-- Since type identifiers and normal identifiers (e.g. functions, variables
-- or constructors) don't share the same namespace, it is necessary
-- to distinguish them in the scope environment of the check state.
-- For this reason type identifiers are annotated with 1 and normal
-- identifiers are annotated with 0.
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


-- --------------------------------------------------------------------------
-- Check Case Mode
-- --------------------------------------------------------------------------


-- The following functions traverse the AST and search for (defining)
-- identifiers and check if their names have the appropriate case mode.
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

-- ---------------------------------------------------------------------------
-- Warnings messages
-- ---------------------------------------------------------------------------

warnCaseMode :: Ident -> CaseMode -> Message
warnCaseMode :: Ident -> CaseMode -> Message
warnCaseMode i :: Ident
i@(Ident _ name :: String
name _ ) c :: CaseMode
c = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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 p. HasPosition p => p -> Doc -> Message
posMessage 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)

warnTypeShadowing :: Ident -> Ident -> Message
warnTypeShadowing :: Ident -> Ident -> Message
warnTypeShadowing x :: Ident
x v :: Ident
v = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
x (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Shadowing type variable" 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)