{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
module AsyncRattus.Plugin.ScopeCheck (checkAll) where
import AsyncRattus.Plugin.Utils
import AsyncRattus.Plugin.Dependency
import AsyncRattus.Plugin.Annotation
import Control.Monad.Trans.State.Strict
import Data.IORef
import Prelude hiding ((<>))
import GHC.Parser.Annotation
import GHC.Plugins
import GHC.Tc.Types
import GHC.Data.Bag
import GHC.Tc.Types.Evidence
import GHC.Hs.Extension
import GHC.Hs.Expr
import GHC.Hs.Pat
import GHC.Hs.Binds
import Data.Graph
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set (Set)
import Data.Map (Map)
import Data.List
import Data.List.NonEmpty (NonEmpty(..),(<|),nonEmpty)
import System.Exit
import Data.Either
import Data.Maybe
import Data.Data hiding (tyConName)
import Control.Monad
type ErrorMsg = (Severity,SrcSpan,SDoc)
type ErrorMsgsRef = IORef [ErrorMsg]
data Ctxt = Ctxt
{
Ctxt -> ErrorMsgsRef
errorMsgs :: ErrorMsgsRef,
Ctxt -> Set Var
current :: LCtxt,
Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier :: Either NoTickReason (NonEmpty LCtxt),
Ctxt -> Hidden
hidden :: Hidden,
Ctxt -> SrcSpan
srcLoc :: SrcSpan,
Ctxt -> Maybe RecDef
recDef :: Maybe RecDef,
Ctxt -> Set Var
stableTypes :: Set Var,
Ctxt -> Map Var Prim
primAlias :: Map Var Prim,
Ctxt -> Bool
allowRecursion :: Bool}
emptyCtxt :: ErrorMsgsRef -> Maybe (Set Var,SrcSpan) -> Bool -> Ctxt
emptyCtxt :: ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
em Maybe RecDef
mvar Bool
allowRec =
Ctxt { errorMsgs :: ErrorMsgsRef
errorMsgs = ErrorMsgsRef
em,
current :: Set Var
current = Set Var
forall a. Set a
Set.empty,
earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = NoTickReason -> Either NoTickReason (NonEmpty (Set Var))
forall a b. a -> Either a b
Left NoTickReason
NoDelay,
hidden :: Hidden
hidden = Hidden
forall k a. Map k a
Map.empty,
srcLoc :: SrcSpan
srcLoc = SrcSpan
noLocationInfo,
recDef :: Maybe RecDef
recDef = Maybe RecDef
mvar,
primAlias :: Map Var Prim
primAlias = Map Var Prim
forall k a. Map k a
Map.empty,
stableTypes :: Set Var
stableTypes = Set Var
forall a. Set a
Set.empty,
allowRecursion :: Bool
allowRecursion = Bool
allowRec}
type LCtxt = Set Var
type RecDef = (Set Var, SrcSpan)
data StableReason = StableRec SrcSpan | StableBox deriving Int -> StableReason -> ShowS
[StableReason] -> ShowS
StableReason -> String
(Int -> StableReason -> ShowS)
-> (StableReason -> String)
-> ([StableReason] -> ShowS)
-> Show StableReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StableReason -> ShowS
showsPrec :: Int -> StableReason -> ShowS
$cshow :: StableReason -> String
show :: StableReason -> String
$cshowList :: [StableReason] -> ShowS
showList :: [StableReason] -> ShowS
Show
data HiddenReason = Stabilize StableReason | FunDef | DelayApp | AdvApp | SelectApp deriving Int -> HiddenReason -> ShowS
[HiddenReason] -> ShowS
HiddenReason -> String
(Int -> HiddenReason -> ShowS)
-> (HiddenReason -> String)
-> ([HiddenReason] -> ShowS)
-> Show HiddenReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HiddenReason -> ShowS
showsPrec :: Int -> HiddenReason -> ShowS
$cshow :: HiddenReason -> String
show :: HiddenReason -> String
$cshowList :: [HiddenReason] -> ShowS
showList :: [HiddenReason] -> ShowS
Show
data NoTickReason = NoDelay | TickHidden HiddenReason deriving Int -> NoTickReason -> ShowS
[NoTickReason] -> ShowS
NoTickReason -> String
(Int -> NoTickReason -> ShowS)
-> (NoTickReason -> String)
-> ([NoTickReason] -> ShowS)
-> Show NoTickReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoTickReason -> ShowS
showsPrec :: Int -> NoTickReason -> ShowS
$cshow :: NoTickReason -> String
show :: NoTickReason -> String
$cshowList :: [NoTickReason] -> ShowS
showList :: [NoTickReason] -> ShowS
Show
type Hidden = Map Var HiddenReason
data Prim = Delay | Adv | Select | Box | Unbox deriving Int -> Prim -> ShowS
[Prim] -> ShowS
Prim -> String
(Int -> Prim -> ShowS)
-> (Prim -> String) -> ([Prim] -> ShowS) -> Show Prim
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prim -> ShowS
showsPrec :: Int -> Prim -> ShowS
$cshow :: Prim -> String
show :: Prim -> String
$cshowList :: [Prim] -> ShowS
showList :: [Prim] -> ShowS
Show
type GetCtxt = ?ctxt :: Ctxt
type CheckM = StateT ([Maybe (Prim, SrcSpan)]) TcM
class Scope a where
check :: GetCtxt => a -> CheckM Bool
class ScopeBind a where
checkBind :: GetCtxt => a -> CheckM (Bool,Set Var)
setCtxt :: Ctxt -> (GetCtxt => a) -> a
setCtxt :: forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c GetCtxt => a
a = let ?ctxt = GetCtxt
Ctxt
c in a
GetCtxt => a
a
modifyCtxt :: (Ctxt -> Ctxt) -> (GetCtxt => a) -> (GetCtxt => a)
modifyCtxt :: forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
modifyCtxt Ctxt -> Ctxt
f GetCtxt => a
a =
let newc :: Ctxt
newc = Ctxt -> Ctxt
f GetCtxt
Ctxt
?ctxt in
let ?ctxt = GetCtxt
Ctxt
newc in a
GetCtxt => a
a
getLocAnn' :: SrcSpanAnn' b -> SrcSpan
getLocAnn' :: forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' = SrcSpanAnn' b -> SrcSpan
forall b. SrcSpanAnn' b -> SrcSpan
locA
updateLoc :: SrcSpanAnn' b -> (GetCtxt => a) -> (GetCtxt => a)
updateLoc :: forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
src = (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
modifyCtxt (\Ctxt
c -> Ctxt
c {srcLoc = getLocAnn' src})
checkAll :: TcGblEnv -> TcM ()
checkAll :: TcGblEnv -> TcM ()
checkAll TcGblEnv
env = do
let bindDep :: [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
bindDep = Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency (TcGblEnv -> Bag (LHsBindLR GhcTc GhcTc)
tcg_binds TcGblEnv
env)
[(Bool, [ErrorMsg])]
result <- (SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg]))
-> [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Bool, [ErrorMsg])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
checkSCC' (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
[SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep
let (Bool
res,[ErrorMsg]
msgs) = ((Bool, [ErrorMsg]) -> (Bool, [ErrorMsg]) -> (Bool, [ErrorMsg]))
-> (Bool, [ErrorMsg]) -> [(Bool, [ErrorMsg])] -> (Bool, [ErrorMsg])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Bool
b,[ErrorMsg]
l) (Bool
b',[ErrorMsg]
l') -> (Bool
b Bool -> Bool -> Bool
&& Bool
b', [ErrorMsg]
l [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
l')) (Bool
True,[]) [(Bool, [ErrorMsg])]
result
[ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs
if Bool
res then () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () else IO () -> TcM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
exitFailure
printAccErrMsgs :: [ErrorMsg] -> TcM ()
printAccErrMsgs :: [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs = (ErrorMsg -> TcM ()) -> [ErrorMsg] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ErrorMsg -> TcM ()
forall {m :: * -> *}.
(HasDynFlags m, MonadIO m, HasLogger m) =>
ErrorMsg -> m ()
printMsg ((ErrorMsg -> SrcSpan) -> [ErrorMsg] -> [ErrorMsg]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Severity
_,SrcSpan
l,SDoc
_)->SrcSpan
l) [ErrorMsg]
msgs)
where printMsg :: ErrorMsg -> m ()
printMsg (Severity
sev,SrcSpan
loc,SDoc
doc) = Severity -> SrcSpan -> SDoc -> m ()
forall (m :: * -> *).
(HasDynFlags m, MonadIO m, HasLogger m) =>
Severity -> SrcSpan -> SDoc -> m ()
printMessage Severity
sev SrcSpan
loc SDoc
doc
instance Scope a => Scope (GenLocated SrcSpan a) where
check :: GetCtxt => GenLocated SrcSpan a -> CheckM Bool
check (L SrcSpan
l a
x) = (\Ctxt
c -> Ctxt
c {srcLoc = l}) (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x
instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where
check :: GetCtxt => GenLocated (SrcSpanAnn' b) a -> CheckM Bool
check (L SrcSpanAnn' b
l a
x) = SrcSpanAnn' b -> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l ((GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a b. (a -> b) -> a -> b
$ a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x
instance Scope a => Scope (Bag a) where
check :: GetCtxt => Bag a -> CheckM Bool
check Bag a
bs = ([Bool] -> Bool)
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
-> CheckM Bool
forall a b.
(a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((a -> CheckM Bool)
-> [a]
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check (Bag a -> [a]
forall a. Bag a -> [a]
bagToList Bag a
bs))
instance Scope a => Scope [a] where
check :: GetCtxt => [a] -> CheckM Bool
check [a]
ls = ([Bool] -> Bool)
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
-> CheckM Bool
forall a b.
(a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((a -> CheckM Bool)
-> [a]
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [a]
ls)
instance Scope (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
check :: GetCtxt =>
Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> CheckM Bool
check Match{m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[LPat GhcTc]
ps,m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs} = Set Var -> Ctxt -> Ctxt
addVars ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> Set Var
forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
ps) (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs
instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
check :: GetCtxt =>
Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> CheckM Bool
check Match{m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[LPat GhcTc]
ps,m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
rhs} = Set Var -> Ctxt -> Ctxt
addVars ([GenLocated SrcSpanAnnA (Pat GhcTc)] -> Set Var
forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
ps) (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
rhs
instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
check :: GetCtxt =>
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
alts} = GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts
instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
check :: GetCtxt =>
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> CheckM Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
alts} = GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
alts
instance Scope a => ScopeBind (StmtLR GhcTc GhcTc a) where
checkBind :: GetCtxt => StmtLR GhcTc GhcTc a -> CheckM (Bool, Set Var)
checkBind (LastStmt XLastStmt GhcTc GhcTc a
_ a
b Maybe Bool
_ SyntaxExpr GhcTc
_) = ( , Set Var
forall a. Set a
Set.empty) (Bool -> (Bool, Set Var)) -> CheckM Bool -> CheckM (Bool, Set Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b
checkBind (BindStmt XBindStmt GhcTc GhcTc a
_ LPat GhcTc
p a
b) = do
let vs :: Set Var
vs = GenLocated SrcSpanAnnA (Pat GhcTc) -> Set Var
forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
p
let c' :: Ctxt
c' = Set Var -> Ctxt -> Ctxt
addVars Set Var
vs GetCtxt
Ctxt
?ctxt
Bool
r <- Ctxt -> (GetCtxt => CheckM Bool) -> CheckM Bool
forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c' (a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b)
(Bool, Set Var) -> CheckM (Bool, Set Var)
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r,Set Var
vs)
checkBind (BodyStmt XBodyStmt GhcTc GhcTc a
_ a
b SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_) = ( , Set Var
forall a. Set a
Set.empty) (Bool -> (Bool, Set Var)) -> CheckM Bool -> CheckM (Bool, Set Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b
checkBind (LetStmt XLetStmt GhcTc GhcTc a
_ HsLocalBindsLR GhcTc GhcTc
bs) = HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
checkBind ParStmt{} = SDoc -> CheckM (Bool, Set Var)
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"monad comprehensions"
checkBind TransStmt{} = SDoc -> CheckM (Bool, Set Var)
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"monad comprehensions"
checkBind ApplicativeStmt{} = SDoc -> CheckM (Bool, Set Var)
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"applicative do notation"
checkBind RecStmt{} = SDoc -> CheckM (Bool, Set Var)
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"recursive do notation"
instance ScopeBind a => ScopeBind [a] where
checkBind :: GetCtxt => [a] -> CheckM (Bool, Set Var)
checkBind [] = (Bool, Set Var) -> CheckM (Bool, Set Var)
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,Set Var
forall a. Set a
Set.empty)
checkBind (a
x:[a]
xs) = do
(Bool
r,Set Var
vs) <- a -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind a
x
(Bool
r',Set Var
vs') <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs (Ctxt -> Ctxt)
-> (GetCtxt => CheckM (Bool, Set Var))
-> GetCtxt => CheckM (Bool, Set Var)
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` ([a] -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [a]
xs)
(Bool, Set Var) -> CheckM (Bool, Set Var)
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r',Set Var
vs Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Var
vs')
instance ScopeBind a => ScopeBind (GenLocated SrcSpan a) where
checkBind :: GetCtxt => GenLocated SrcSpan a -> CheckM (Bool, Set Var)
checkBind (L SrcSpan
l a
x) = (\Ctxt
c -> Ctxt
c {srcLoc = l}) (Ctxt -> Ctxt)
-> (GetCtxt => CheckM (Bool, Set Var))
-> GetCtxt => CheckM (Bool, Set Var)
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` a -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind a
x
instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where
checkBind :: GetCtxt => GenLocated (SrcSpanAnn' b) a -> CheckM (Bool, Set Var)
checkBind (L SrcSpanAnn' b
l a
x) = SrcSpanAnn' b
-> (GetCtxt => CheckM (Bool, Set Var))
-> GetCtxt => CheckM (Bool, Set Var)
forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l ((GetCtxt => CheckM (Bool, Set Var))
-> GetCtxt => CheckM (Bool, Set Var))
-> (GetCtxt => CheckM (Bool, Set Var))
-> GetCtxt => CheckM (Bool, Set Var)
forall a b. (a -> b) -> a -> b
$ a -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind a
x
instance Scope a => Scope (GRHS GhcTc a) where
check :: GetCtxt => GRHS GhcTc a -> CheckM Bool
check (GRHS XCGRHS GhcTc a
_ [GuardLStmt GhcTc]
gs a
b) = do
(Bool
r, Set Var
vs) <- [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [GuardLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
gs
Bool
r' <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r')
checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec LHsBindLR GhcTc GhcTc
b = (Bool -> Bool -> Bool) -> CheckM Bool -> CheckM Bool -> CheckM Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind LHsBindLR GhcTc GhcTc
b) (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsBindLR GhcTc GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b)
checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind (L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
b) = SrcSpanAnnA -> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnnA
l ((GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a b. (a -> b) -> a -> b
$ GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
HsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind' HsBindLR GhcTc GhcTc
b
checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind' PatBind{} = do
GetCtxt => Severity -> SDoc -> CheckM ()
Severity -> SDoc -> CheckM ()
printMessage' Severity
SevError (SDoc
"(Mutual) recursive pattern binding definitions are not supported in Asynchronous Rattus")
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
#if __GLASGOW_HASKELL__ < 904
checkPatBind' AbsBinds {abs_binds = binds} =
#else
checkPatBind' (XHsBindsLR AbsBinds {abs_binds :: AbsBinds -> Bag (LHsBindLR GhcTc GhcTc)
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds}) =
#endif
([Bool] -> Bool)
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
-> CheckM Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
LHsBindLR GhcTc GhcTc -> CheckM Bool
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
checkPatBind (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds))
checkPatBind' HsBindLR GhcTc GhcTc
_ = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkRecursiveBinds :: GetCtxt => [LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
checkRecursiveBinds :: GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
checkRecursiveBinds [LHsBindLR GhcTc GhcTc]
bs Set Var
vs = do
Bool
res <- ([Bool] -> Bool)
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
-> CheckM Bool
forall a b.
(a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
check' [LHsBindLR GhcTc GhcTc]
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs)
(Bool, Set Var) -> CheckM (Bool, Set Var)
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, Set Var
vs)
where check' :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
check' b :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b@(L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_) = SrcSpan -> Ctxt -> Ctxt
fc (SrcSpanAnnA -> SrcSpan
forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l) (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec LHsBindLR GhcTc GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
fc :: SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l Ctxt
c = let
ctxHid :: Set Var
ctxHid = (NoTickReason -> Set Var)
-> (NonEmpty (Set Var) -> Set Var)
-> Either NoTickReason (NonEmpty (Set Var))
-> Set Var
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Set Var -> NoTickReason -> Set Var
forall a b. a -> b -> a
const (Set Var -> NoTickReason -> Set Var)
-> Set Var -> NoTickReason -> Set Var
forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c) (Set Var -> Set Var)
-> (NonEmpty (Set Var) -> Set Var) -> NonEmpty (Set Var) -> Set Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Set Var) -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c)
in Ctxt
c {current = Set.empty,
earlier = Left (TickHidden $ Stabilize $ StableRec l),
hidden = hidden c `Map.union`
(Map.fromSet (const (Stabilize (StableRec l))) ctxHid),
recDef = maybe (Just (vs,l)) (\(Set Var
vs',SrcSpan
_) -> RecDef -> Maybe RecDef
forall a. a -> Maybe a
Just (Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Var
vs' Set Var
vs,SrcSpan
l)) (recDef c)
}
instance ScopeBind (SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)) where
checkBind :: GetCtxt =>
SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> CheckM (Bool, Set Var)
checkBind (AcyclicSCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b,Set Var
vs)) = (, Set Var
vs) (Bool -> (Bool, Set Var)) -> CheckM Bool -> CheckM (Bool, Set Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
checkBind (CyclicSCC [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) = GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
checkRecursiveBinds (((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a, b) -> a
fst [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) (((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> Set Var)
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> Set Var
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var) -> Set Var
forall a b. (a, b) -> b
snd [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs)
instance ScopeBind (HsValBindsLR GhcTc GhcTc) where
checkBind :: GetCtxt => HsValBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind (ValBinds XValBinds GhcTc GhcTc
_ Bag (LHsBindLR GhcTc GhcTc)
bs [LSig GhcTc]
_) = [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind (Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency Bag (LHsBindLR GhcTc GhcTc)
bs)
checkBind (XValBindsLR (NValBinds [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds [LSig GhcRn]
_)) = [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds
instance ScopeBind (HsBindLR GhcTc GhcTc) where
checkBind :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind HsBindLR GhcTc GhcTc
b = (, HsBindLR GhcTc GhcTc -> Set Var
forall a. HasBV a => a -> Set Var
getBV HsBindLR GhcTc GhcTc
b) (Bool -> (Bool, Set Var)) -> CheckM Bool -> CheckM (Bool, Set Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsBindLR GhcTc GhcTc -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsBindLR GhcTc GhcTc
b
getAllBV :: GenLocated l (HsBindLR GhcTc GhcTc) -> Set Var
getAllBV :: forall l. GenLocated l (HsBindLR GhcTc GhcTc) -> Set Var
getAllBV (L l
_ HsBindLR GhcTc GhcTc
b) = HsBindLR GhcTc GhcTc -> Set Var
forall {idL} {l} {idR}.
(XRec idL Var ~ GenLocated l Var, XXHsBindsLR idL idR ~ AbsBinds,
IdP idL ~ Var, HasBV (XRec idL (Pat idL))) =>
HsBindLR idL idR -> Set Var
getAllBV' HsBindLR GhcTc GhcTc
b where
getAllBV' :: HsBindLR idL idR -> Set Var
getAllBV' (FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L l
_ Var
v}) = Var -> Set Var
forall a. a -> Set a
Set.singleton Var
v
#if __GLASGOW_HASKELL__ < 904
getAllBV' (AbsBinds {abs_exports = es, abs_binds = bs}) = Set.fromList (map abe_poly es) `Set.union` foldMap getBV bs
getAllBV' XHsBindsLR{} = Set.empty
#else
getAllBV' (XHsBindsLR (AbsBinds {abs_exports :: AbsBinds -> [ABExport]
abs_exports = [ABExport]
es, abs_binds :: AbsBinds -> Bag (LHsBindLR GhcTc GhcTc)
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
bs})) = [Var] -> Set Var
forall a. Ord a => [a] -> Set a
Set.fromList ((ABExport -> Var) -> [ABExport] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map ABExport -> Var
abe_poly [ABExport]
es) Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Set Var)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> Set Var
forall m a. Monoid m => (a -> m) -> Bag a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Set Var
forall a. HasBV a => a -> Set Var
getBV Bag (LHsBindLR GhcTc GhcTc)
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs
#endif
getAllBV' (PatBind {pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec idL (Pat idL)
pat}) = XRec idL (Pat idL) -> Set Var
forall a. HasBV a => a -> Set Var
getBV XRec idL (Pat idL)
pat
getAllBV' (VarBind {var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP idL
v}) = Var -> Set Var
forall a. a -> Set a
Set.singleton IdP idL
Var
v
getAllBV' PatSynBind{} = Set Var
forall a. Set a
Set.empty
instance ScopeBind (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))) where
checkBind :: GetCtxt =>
(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> CheckM (Bool, Set Var)
checkBind (RecFlag
NonRecursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs) = [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> CheckM (Bool, Set Var))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> CheckM (Bool, Set Var)
forall a b. (a -> b) -> a -> b
$ Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs
checkBind (RecFlag
Recursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs) = GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
checkRecursiveBinds [LHsBindLR GhcTc GhcTc]
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Set Var)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> Set Var
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Set Var
forall l. GenLocated l (HsBindLR GhcTc GhcTc) -> Set Var
getAllBV [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs')
where bs' :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs
instance ScopeBind (HsLocalBindsLR GhcTc GhcTc) where
checkBind :: GetCtxt => HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind (HsValBinds XHsValBinds GhcTc GhcTc
_ HsValBindsLR GhcTc GhcTc
bs) = HsValBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsValBindsLR GhcTc GhcTc
bs
checkBind HsIPBinds {} = SDoc -> CheckM (Bool, Set Var)
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"implicit parameters"
checkBind EmptyLocalBinds{} = (Bool, Set Var) -> CheckM (Bool, Set Var)
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,Set Var
forall a. Set a
Set.empty)
type SrcAnno = SrcSpanAnnA
instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
check :: GetCtxt =>
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> CheckM Bool
check GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rhs, grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds = HsLocalBindsLR GhcTc GhcTc
lbinds} = do
(Bool
l,Set Var
vs) <- HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
lbinds
Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` ([GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
[GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rhs)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
check :: GetCtxt =>
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> CheckM Bool
check GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
rhs, grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds = HsLocalBindsLR GhcTc GhcTc
lbinds} = do
(Bool
l,Set Var
vs) <- HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
lbinds
Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` ([GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
[GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
rhs)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
instance Show Var where
show :: Var -> String
show Var
v = Var -> String
forall a. NamedThing a => a -> String
getOccString Var
v
tickHidden :: HiddenReason -> SDoc
tickHidden :: HiddenReason -> SDoc
tickHidden HiddenReason
FunDef = SDoc
"a function definition"
tickHidden HiddenReason
DelayApp = SDoc
"a nested application of delay"
tickHidden HiddenReason
AdvApp = SDoc
"an application of adv"
tickHidden HiddenReason
SelectApp = SDoc
"an application of select"
tickHidden (Stabilize StableReason
StableBox) = SDoc
"an application of box"
tickHidden (Stabilize (StableRec SrcSpan
src)) = SDoc
"a nested recursive definition (at " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
src SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
")"
isSelect :: GetCtxt => LHsExpr GhcTc -> Bool
isSelect :: GetCtxt => LHsExpr GhcTc -> Bool
isSelect LHsExpr GhcTc
e =
case GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e of
Just (Prim
Select, Var
_) -> Bool
True
Maybe (Prim, Var)
_ -> Bool
False
instance Scope (HsExpr GhcTc) where
check :: GetCtxt => HsExpr GhcTc -> CheckM Bool
check (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
v))
| Just Prim
p <- GetCtxt => Var -> Maybe Prim
Var -> Maybe Prim
isPrim Var
v =
case Prim
p of
Prim
Unbox -> Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Prim
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"Defining an alias for " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is not allowed")
| Bool
otherwise = case GetCtxt => Var -> VarScope
Var -> VarScope
getScope Var
v of
Hidden SDoc
reason -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
reason
VarScope
Visible -> Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
VarScope
ImplUnboxed -> Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check (HsApp XApp GhcTc
_ (L SrcSpanAnnA
_ (HsApp XApp GhcTc
_ LHsExpr GhcTc
f LHsExpr GhcTc
arg)) LHsExpr GhcTc
arg2) | GetCtxt => LHsExpr GhcTc -> Bool
LHsExpr GhcTc -> Bool
isSelect LHsExpr GhcTc
f =
case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
Ctxt
?ctxt of
Right (Set Var
er :| [Set Var]
ers) -> do
[Maybe (Prim, SrcSpan)]
res <- StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
[Maybe (Prim, SrcSpan)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
case [Maybe (Prim, SrcSpan)]
res of
Just (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"only one adv or select may be used in the scope of a delay.")
Maybe (Prim, SrcSpan)
Nothing : [Maybe (Prim, SrcSpan)]
pre -> do [Maybe (Prim, SrcSpan)] -> CheckM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre
Bool
b1 <- Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
arg
Bool
b2 <- Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
arg2
([Maybe (Prim, SrcSpan)] -> [Maybe (Prim, SrcSpan)]) -> CheckM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Prim, SrcSpan) -> Maybe (Prim, SrcSpan)
forall a. a -> Maybe a
Just (Prim
Select, Ctxt -> SrcSpan
srcLoc GetCtxt
Ctxt
?ctxt) Maybe (Prim, SrcSpan)
-> [Maybe (Prim, SrcSpan)] -> [Maybe (Prim, SrcSpan)]
forall a. a -> [a] -> [a]
:)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> CheckM Bool) -> Bool -> CheckM Bool
forall a b. (a -> b) -> a -> b
$ Bool
b1 Bool -> Bool -> Bool
&& Bool
b2
[Maybe (Prim, SrcSpan)]
_ -> String -> CheckM Bool
forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c{earlier = case nonEmpty ers of
Maybe (NonEmpty (Set Var))
Nothing -> NoTickReason -> Either NoTickReason (NonEmpty (Set Var))
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason (NonEmpty (Set Var)))
-> NoTickReason -> Either NoTickReason (NonEmpty (Set Var))
forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
SelectApp
Just NonEmpty (Set Var)
ers' -> NonEmpty (Set Var) -> Either NoTickReason (NonEmpty (Set Var))
forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
current = er,
hidden = hidden ?ctxt `Map.union`
Map.fromSet (const SelectApp) (current ?ctxt)}
Left NoTickReason
NoDelay -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
"select may only be used in the scope of a delay."
Left (TickHidden HiddenReason
hr) -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"select may only be used in the scope of a delay. "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
".")
check (HsApp XApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
case GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e1 of
Just (Prim
p,Var
_) -> case Prim
p of
Prim
Box -> do
Bool
ch <- StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableBox (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
Prim
Unbox -> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
Prim
Delay -> do ([Maybe (Prim, SrcSpan)] -> [Maybe (Prim, SrcSpan)]) -> CheckM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Maybe (Prim, SrcSpan)
forall a. Maybe a
Nothing Maybe (Prim, SrcSpan)
-> [Maybe (Prim, SrcSpan)] -> [Maybe (Prim, SrcSpan)]
forall a. a -> [a] -> [a]
:)
Bool
b <- (\Ctxt
c -> Ctxt
c{current = Set.empty,
earlier = case earlier c of
Left NoTickReason
_ -> NonEmpty (Set Var) -> Either NoTickReason (NonEmpty (Set Var))
forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c Set Var -> [Set Var] -> NonEmpty (Set Var)
forall a. a -> [a] -> NonEmpty a
:| [])
Right NonEmpty (Set Var)
cs -> NonEmpty (Set Var) -> Either NoTickReason (NonEmpty (Set Var))
forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c Set Var -> NonEmpty (Set Var) -> NonEmpty (Set Var)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (Set Var)
cs)})
(Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
[Maybe (Prim, SrcSpan)]
res <- StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
[Maybe (Prim, SrcSpan)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
case [Maybe (Prim, SrcSpan)]
res of
Maybe (Prim, SrcSpan)
Nothing : [Maybe (Prim, SrcSpan)]
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
"No adv or select found in the scope of this occurrence of delay"
Maybe (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
pre -> [Maybe (Prim, SrcSpan)] -> CheckM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre CheckM () -> CheckM Bool -> CheckM Bool
forall a b.
StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
[Maybe (Prim, SrcSpan)]
_ -> String -> CheckM Bool
forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
Prim
Adv -> case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
Ctxt
?ctxt of
Right (Set Var
er :| [Set Var]
ers) -> do
[Maybe (Prim, SrcSpan)]
res <- StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
[Maybe (Prim, SrcSpan)]
forall (m :: * -> *) s. Monad m => StateT s m s
get
case [Maybe (Prim, SrcSpan)]
res of
Just (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"only one adv or select may be used in the scope of a delay.")
Maybe (Prim, SrcSpan)
Nothing : [Maybe (Prim, SrcSpan)]
pre -> do [Maybe (Prim, SrcSpan)] -> CheckM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre
Bool
b <- Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
([Maybe (Prim, SrcSpan)] -> [Maybe (Prim, SrcSpan)]) -> CheckM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Prim, SrcSpan) -> Maybe (Prim, SrcSpan)
forall a. a -> Maybe a
Just (Prim
Adv,Ctxt -> SrcSpan
srcLoc GetCtxt
Ctxt
?ctxt) Maybe (Prim, SrcSpan)
-> [Maybe (Prim, SrcSpan)] -> [Maybe (Prim, SrcSpan)]
forall a. a -> [a] -> [a]
:)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
[Maybe (Prim, SrcSpan)]
_ -> String -> CheckM Bool
forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c{earlier = case nonEmpty ers of
Maybe (NonEmpty (Set Var))
Nothing -> NoTickReason -> Either NoTickReason (NonEmpty (Set Var))
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason (NonEmpty (Set Var)))
-> NoTickReason -> Either NoTickReason (NonEmpty (Set Var))
forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
AdvApp
Just NonEmpty (Set Var)
ers' -> NonEmpty (Set Var) -> Either NoTickReason (NonEmpty (Set Var))
forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
current = er,
hidden = hidden ?ctxt `Map.union`
Map.fromSet (const AdvApp) (current ?ctxt)}
Left NoTickReason
NoDelay -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay.")
Left (TickHidden HiddenReason
hr) -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay. "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
".")
Prim
Select -> GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"select must be fully applied")
Maybe (Prim, Var)
_ -> (Bool -> Bool -> Bool) -> CheckM Bool -> CheckM Bool -> CheckM Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1) (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2)
check HsUnboundVar{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if __GLASGOW_HASKELL__ >= 904
check (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ LHsExpr GhcTc
e LHsToken ")" GhcTc
_) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (HsLamCase XLamCase GhcTc
_ LamCaseVariant
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg
check HsRecSel{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsTypedBracket{} = SDoc -> CheckM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
check HsUntypedBracket{} = SDoc -> CheckM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
#else
check HsConLikeOut{} = return True
check HsRecFld{} = return True
check (HsPar _ e) = check e
check (HsLamCase _ mg) = check mg
check HsBracket{} = notSupported "MetaHaskell"
check (HsTick _ _ e) = check e
check (HsBinTick _ _ _ e) = check e
check HsRnBracketOut{} = notSupported "MetaHaskell"
check HsTcBracketOut{} = notSupported "MetaHaskell"
#endif
#if __GLASGOW_HASKELL__ >= 904
check (HsLet XLet GhcTc
_ LHsToken "let" GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsToken "in" GhcTc
_ LHsExpr GhcTc
e) = do
#else
check (HsLet _ bs e) = do
#endif
(Bool
l,Set Var
vs) <- HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
check HsOverLabel{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsIPVar{} = SDoc -> CheckM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"implicit parameters"
check HsOverLit{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsLit{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check (OpApp XOpApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
-> CheckM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1,LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2,LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e3]
check (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg
check (HsCase XCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsExpr GhcTc)
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
e2
check (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
check (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
check (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
e Boxity
_) = [HsTupArg GhcTc] -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [HsTupArg GhcTc]
e
check (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
_) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (HsMultiIf XMultiIf GhcTc
_ [LGRHS GhcTc (LHsExpr GhcTc)]
e) = [GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
e
check (ExplicitList XExplicitList GhcTc
_ [LHsExpr GhcTc]
e) = [GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
e
check HsProjection {} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsGetField {gf_expr :: forall p. HsExpr p -> LHsExpr p
gf_expr = LHsExpr GhcTc
e} = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
fs} = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
Either
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldLabelStrings GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
fs
check RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
f} = HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsRecordBinds GhcTc
HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
f
check (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ ArithSeqInfo GhcTc
e) = ArithSeqInfo GhcTc -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check ArithSeqInfo GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
check HsTypedSplice{} = SDoc -> CheckM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"Template Haskell"
check HsUntypedSplice{} = SDoc -> CheckM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"Template Haskell"
#else
check HsSpliceE{} = notSupported "Template Haskell"
#endif
check (HsProc XProc GhcTc
_ LPat GhcTc
_ LHsCmdTop GhcTc
e) = GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmdTop GhcTc
GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)
e
check (HsStatic XStatic GhcTc
_ LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (HsDo XDo GhcTc
_ HsDoFlavour
_ XRec GhcTc [GuardLStmt GhcTc]
e) = (Bool, Set Var) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Set Var) -> Bool) -> CheckM (Bool, Set Var) -> CheckM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind XRec GhcTc [GuardLStmt GhcTc]
GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
e
check (XExpr XXExpr GhcTc
e) = XXExprGhcTc -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XXExpr GhcTc
XXExprGhcTc
e
#if __GLASGOW_HASKELL__ >= 906
check (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsToken "@" GhcTc
_ LHsWcType (NoGhcTc GhcTc)
_) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
#else
check (HsAppType _ e _) = check e
check (ExprWithTySig _ e _) = check e
#endif
check (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (HsIf XIf GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
-> CheckM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1,LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2,LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e3]
instance (Scope a, Scope b) => Scope (Either a b) where
check :: GetCtxt => Either a b -> CheckM Bool
check (Left a
x) = a -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x
check (Right b
x) = b -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check b
x
#if __GLASGOW_HASKELL__ >= 908
instance Scope (LHsRecUpdFields GhcTc) where
check RegularRecUpdFields {recUpdFields = x} = check x
check OverloadedRecUpdFields {olRecUpdFields = x} = check x
#endif
instance Scope XXExprGhcTc where
check :: GetCtxt => XXExprGhcTc -> CheckM Bool
check (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e)) = HsExpr GhcTc -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsExpr GhcTc
e
check (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e)) = HsExpr GhcTc -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 904
check ConLikeTc{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check (HsTick CoreTickish
_ LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (HsBinTick Int
_ Int
_ LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
#endif
instance Scope (HsCmdTop GhcTc) where
check :: GetCtxt => HsCmdTop GhcTc -> CheckM Bool
check (HsCmdTop XCmdTop GhcTc
_ LHsCmd GhcTc
e) = GenLocated SrcSpanAnnA (HsCmd GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
GenLocated SrcSpanAnnA (HsCmd GhcTc)
e
instance Scope (HsCmd GhcTc) where
check :: GetCtxt => HsCmd GhcTc -> CheckM Bool
check (HsCmdArrApp XCmdArrApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
_ Bool
_) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
check (HsCmdDo XCmdDo GhcTc
_ XRec GhcTc [CmdLStmt GhcTc]
e) = (Bool, Set Var) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Set Var) -> Bool) -> CheckM (Bool, Set Var) -> CheckM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
-> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind XRec GhcTc [CmdLStmt GhcTc]
GenLocated
SrcSpanAnnL
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)))]
e
check (HsCmdArrForm XCmdArrForm GhcTc
_ LHsExpr GhcTc
e1 LexicalFixity
_ Maybe Fixity
_ [LHsCmdTop GhcTc]
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)] -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsCmdTop GhcTc]
[GenLocated (SrcAnn NoEpAnns) (HsCmdTop GhcTc)]
e2
check (HsCmdApp XCmdApp GhcTc
_ LHsCmd GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsCmd GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
GenLocated SrcSpanAnnA (HsCmd GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
check (HsCmdLam XCmdLam GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
e
#if __GLASGOW_HASKELL__ >= 904
check (HsCmdPar XCmdPar GhcTc
_ LHsToken "(" GhcTc
_ LHsCmd GhcTc
e LHsToken ")" GhcTc
_) = GenLocated SrcSpanAnnA (HsCmd GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
GenLocated SrcSpanAnnA (HsCmd GhcTc)
e
check (HsCmdLamCase XCmdLamCase GhcTc
_ LamCaseVariant
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
e
check (HsCmdLet XCmdLet GhcTc
_ LHsToken "let" GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsToken "in" GhcTc
_ LHsCmd GhcTc
e) = do
#else
check (HsCmdPar _ e) = check e
check (HsCmdLamCase _ e) = check e
check (HsCmdLet _ bs e) = do
#endif
(Bool
l,Set Var
vs) <- HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (GenLocated SrcSpanAnnA (HsCmd GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
GenLocated SrcSpanAnnA (HsCmd GhcTc)
e)
Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
check (HsCmdCase XCmdCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsCmd GhcTc)
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
e2
check (HsCmdIf XCmdIf GhcTc
_ SyntaxExpr GhcTc
_ LHsExpr GhcTc
e1 LHsCmd GhcTc
e2 LHsCmd GhcTc
e3) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsCmd GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
GenLocated SrcSpanAnnA (HsCmd GhcTc)
e2) StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsCmd GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
GenLocated SrcSpanAnnA (HsCmd GhcTc)
e3
check (XCmd (HsWrap HsWrapper
_ HsCmd GhcTc
e)) = HsCmd GhcTc -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsCmd GhcTc
e
instance Scope (ArithSeqInfo GhcTc) where
check :: GetCtxt => ArithSeqInfo GhcTc -> CheckM Bool
check (From LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
check (FromTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2
check (FromThenTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> CheckM Bool
-> StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e1 StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e2) StateT
[Maybe (Prim, SrcSpan)]
(IOEnv (Env TcGblEnv TcLclEnv))
(Bool -> Bool)
-> CheckM Bool -> CheckM Bool
forall a b.
StateT
[Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) (a -> b)
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e3
instance Scope a => Scope (HsRecFields GhcTc a) where
check :: GetCtxt => HsRecFields GhcTc a -> CheckM Bool
check HsRecFields {rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc a]
fs} = [GenLocated
SrcSpanAnnA
(HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) a)]
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsRecField GhcTc a]
[GenLocated
SrcSpanAnnA
(HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) a)]
fs
#if __GLASGOW_HASKELL__ >= 904
instance Scope b => Scope (HsFieldBind a b) where
check :: GetCtxt => HsFieldBind a b -> CheckM Bool
check HsFieldBind{hfbRHS :: forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS = b
a} = b -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check b
a
#else
instance Scope b => Scope (HsRecField' a b) where
check HsRecField{hsRecFieldArg = a} = check a
#endif
instance Scope (HsTupArg GhcTc) where
check :: GetCtxt => HsTupArg GhcTc -> CheckM Bool
check (Present XPresent GhcTc
_ LHsExpr GhcTc
e) = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
e
check Missing{} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
instance Scope (HsBindLR GhcTc GhcTc) where
#if __GLASGOW_HASKELL__ >= 904
check :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
check (XHsBindsLR AbsBinds {abs_binds :: AbsBinds -> Bag (LHsBindLR GhcTc GhcTc)
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds, abs_ev_vars :: AbsBinds -> [Var]
abs_ev_vars = [Var]
ev})
#else
check AbsBinds {abs_binds = binds, abs_ev_vars = ev}
#endif
= Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check Bag (LHsBindLR GhcTc GhcTc)
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes= stableTypes c `Set.union`
Set.fromList (mapMaybe (isStableConstr . varType) ev)}
check FunBind{fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches= MatchGroup GhcTc (LHsExpr GhcTc)
matches, fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Var
v,
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcTc GhcTc
wrapper} =
Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes= stableTypes c `Set.union`
Set.fromList (stableConstrFromWrapper' wrapper) `Set.union`
Set.fromList (extractStableConstr (varType v))}
check PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
lhs, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs=GRHSs GhcTc (LHsExpr GhcTc)
rhs} = Set Var -> Ctxt -> Ctxt
addVars (GenLocated SrcSpanAnnA (Pat GhcTc) -> Set Var
forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
lhs) (Ctxt -> Ctxt)
-> (GetCtxt => CheckM Bool) -> GetCtxt => CheckM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs
check VarBind{var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
rhs} = GenLocated SrcSpanAnnA (HsExpr GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
check PatSynBind {} = Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isStableConstr :: Type -> Maybe TyVar
isStableConstr :: Type -> Maybe Var
isStableConstr Type
t =
case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
Just (TyCon
con,[Type
args]) ->
case TyCon -> Maybe (FastString, FastString)
forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule TyCon
con of
Just (FastString
name, FastString
mod) ->
if FastString -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Stable"
then (Type -> Maybe Var
getTyVar_maybe Type
args)
else Maybe Var
forall a. Maybe a
Nothing
Maybe (FastString, FastString)
_ -> Maybe Var
forall a. Maybe a
Nothing
Maybe (TyCon, [Type])
_ -> Maybe Var
forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 906
stableConstrFromWrapper' :: (HsWrapper , a) -> [TyVar]
stableConstrFromWrapper' :: forall a. (HsWrapper, a) -> [Var]
stableConstrFromWrapper' (HsWrapper
x , a
_) = HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
x
#else
stableConstrFromWrapper' :: HsWrapper -> [TyVar]
stableConstrFromWrapper' = stableConstrFromWrapper
#endif
stableConstrFromWrapper :: HsWrapper -> [TyVar]
stableConstrFromWrapper :: HsWrapper -> [Var]
stableConstrFromWrapper (WpCompose HsWrapper
v HsWrapper
w) = HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
v [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
w
stableConstrFromWrapper (WpEvLam Var
v) = Maybe Var -> [Var]
forall a. Maybe a -> [a]
maybeToList (Maybe Var -> [Var]) -> Maybe Var -> [Var]
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Var
isStableConstr (Var -> Type
varType Var
v)
stableConstrFromWrapper HsWrapper
_ = []
extractStableConstr :: Type -> [TyVar]
= (Type -> Maybe Var) -> [Type] -> [Var]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Var
isStableConstr ([Type] -> [Var]) -> (Type -> [Type]) -> Type -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
irrelevantMult ([Scaled Type] -> [Type])
-> (Type -> [Scaled Type]) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Scaled Type], Type) -> [Scaled Type]
forall a b. (a, b) -> a
fst (([Scaled Type], Type) -> [Scaled Type])
-> (Type -> ([Scaled Type], Type)) -> Type -> [Scaled Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Scaled Type], Type)
splitFunTys (Type -> ([Scaled Type], Type))
-> (Type -> Type) -> Type -> ([Scaled Type], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Var], Type) -> Type
forall a b. (a, b) -> b
snd (([Var], Type) -> Type) -> (Type -> ([Var], Type)) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Var], Type)
splitForAllTys'
getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc (AcyclicSCC (L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_ ,Set Var
_)) = SrcSpanAnnA -> SrcSpan
forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l
getSCCLoc (CyclicSCC ((L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_,Set Var
_ ) : [(LHsBindLR GhcTc GhcTc, Set Var)]
_)) = SrcSpanAnnA -> SrcSpan
forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
_ = SrcSpan
noLocationInfo
checkSCC' :: Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg])
checkSCC' :: Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
checkSCC' Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc = do
ErrorMsgsRef
err <- IO ErrorMsgsRef -> IOEnv (Env TcGblEnv TcLclEnv) ErrorMsgsRef
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([ErrorMsg] -> IO ErrorMsgsRef
forall a. a -> IO (IORef a)
newIORef [])
let allowRec :: Bool
allowRec = AsyncRattus
AllowRecursion AsyncRattus -> Set AsyncRattus -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> Set AsyncRattus
forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
Bool
res <- Bool
-> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool
checkSCC Bool
allowRec ErrorMsgsRef
err SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
[ErrorMsg]
msgs <- IO [ErrorMsg] -> IOEnv (Env TcGblEnv TcLclEnv) [ErrorMsg]
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ErrorMsgsRef -> IO [ErrorMsg]
forall a. IORef a -> IO a
readIORef ErrorMsgsRef
err)
let anns :: Set InternalAnn
anns = Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> Set InternalAnn
forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
if InternalAnn
ExpectWarning InternalAnn -> Set InternalAnn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
then if InternalAnn
ExpectError InternalAnn -> Set InternalAnn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
then (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Annotation to expect both warning and error is not allowed.")])
else if (ErrorMsg -> Bool) -> [ErrorMsg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
True; Severity
_ -> Bool
False) [ErrorMsg]
msgs
then (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, (ErrorMsg -> Bool) -> [ErrorMsg] -> [ErrorMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
False; Severity
_ -> Bool
True) [ErrorMsg]
msgs)
else (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Warning was expected, but typechecking produced no warning.")])
else if InternalAnn
ExpectError InternalAnn -> Set InternalAnn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
then if Bool
res
then (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Error was expected, but typechecking produced no error.")])
else (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[])
else (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, [ErrorMsg]
msgs)
getAnn :: forall a . (Data a, Ord a) => Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn :: forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc =
case SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc of
(AcyclicSCC (LHsBindLR GhcTc GhcTc
_,Set Var
vs)) -> Set (Set a) -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set a) -> Set a) -> Set (Set a) -> Set a
forall a b. (a -> b) -> a -> b
$ (Var -> Set a) -> Set Var -> Set (Set a)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set a
checkVar Set Var
vs
(CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) -> [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set a] -> Set a) -> [Set a] -> Set a
forall a b. (a -> b) -> a -> b
$ ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var) -> Set a)
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map (Set (Set a) -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set a) -> Set a)
-> ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> Set (Set a))
-> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> Set a) -> Set Var -> Set (Set a)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set a
checkVar (Set Var -> Set (Set a))
-> ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> Set Var)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> Set (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var) -> Set Var
forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, Set Var)]
[(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs
where checkVar :: Var -> Set a
checkVar :: Var -> Set a
checkVar Var
v =
let anns :: [a]
anns = ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> a
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (Name -> CoreAnnTarget
forall name. name -> AnnTarget name
NamedTarget Name
name) :: [a]
annsMod :: [a]
annsMod = ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> a
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (Module -> CoreAnnTarget
forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [a]
name :: Name
name :: Name
name = Var -> Name
varName Var
v
in [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
anns Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
annsMod
checkSCC :: Bool -> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool
checkSCC :: Bool
-> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool
checkSCC Bool
allowRec ErrorMsgsRef
errm (AcyclicSCC (LHsBindLR GhcTc GhcTc
b,Set Var
_)) = Ctxt -> (GetCtxt => TcM Bool) -> TcM Bool
forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
errm Maybe RecDef
forall a. Maybe a
Nothing Bool
allowRec) (CheckM Bool -> [Maybe (Prim, SrcSpan)] -> TcM Bool
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsBindLR GhcTc GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b) [])
checkSCC Bool
allowRec ErrorMsgsRef
errm (CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) = (([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool] -> TcM Bool
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs'))
where bs' :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' = ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a, b) -> a
fst [(LHsBindLR GhcTc GhcTc, Set Var)]
[(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs
vs :: Set Var
vs = ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> Set Var)
-> [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
-> Set Var
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var) -> Set Var
forall a b. (a, b) -> b
snd [(LHsBindLR GhcTc GhcTc, Set Var)]
[(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs
check' :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' b :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b@(L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_) = Ctxt -> (GetCtxt => TcM Bool) -> TcM Bool
forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
errm (RecDef -> Maybe RecDef
forall a. a -> Maybe a
Just (Set Var
vs,SrcSpanAnnA -> SrcSpan
forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l)) Bool
allowRec) (CheckM Bool -> [Maybe (Prim, SrcSpan)] -> TcM Bool
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec LHsBindLR GhcTc GhcTc
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b) [])
stabilize :: StableReason -> Ctxt -> Ctxt
stabilize :: StableReason -> Ctxt -> Ctxt
stabilize StableReason
sr Ctxt
c = Ctxt
c
{current = Set.empty,
earlier = Left $ TickHidden hr,
hidden = hidden c `Map.union` Map.fromSet (const hr) ctxHid}
where ctxHid :: Set Var
ctxHid = (NoTickReason -> Set Var)
-> (NonEmpty (Set Var) -> Set Var)
-> Either NoTickReason (NonEmpty (Set Var))
-> Set Var
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Set Var -> NoTickReason -> Set Var
forall a b. a -> b -> a
const (Set Var -> NoTickReason -> Set Var)
-> Set Var -> NoTickReason -> Set Var
forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) ((Set Var -> Set Var -> Set Var)
-> Set Var -> NonEmpty (Set Var) -> Set Var
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c)) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c)
hr :: HiddenReason
hr = StableReason -> HiddenReason
Stabilize StableReason
sr
data VarScope = Hidden SDoc | Visible | ImplUnboxed
getScope :: GetCtxt => Var -> VarScope
getScope :: GetCtxt => Var -> VarScope
getScope Var
v =
case GetCtxt
Ctxt
?ctxt of
Ctxt{recDef :: Ctxt -> Maybe RecDef
recDef = Just (Set Var
vs,SrcSpan
_), earlier :: Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier = Either NoTickReason (NonEmpty (Set Var))
e, allowRecursion :: Ctxt -> Bool
allowRecursion = Bool
allowRec} | Var
v Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Var
vs ->
if Bool
allowRec then VarScope
Visible else
case Either NoTickReason (NonEmpty (Set Var))
e of
Right NonEmpty (Set Var)
_ -> VarScope
Visible
Left NoTickReason
NoDelay -> SDoc -> VarScope
Hidden (SDoc
"The (mutually) recursive call to " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" must occur in the scope of a delay")
Left (TickHidden HiddenReason
hr) -> SDoc -> VarScope
Hidden (SDoc
"The (mutually) recursive call to " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" must occur in the scope of a delay. "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
"There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
".")
Ctxt
_ -> case Var -> Hidden -> Maybe HiddenReason
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Hidden
hidden GetCtxt
Ctxt
?ctxt) of
Just (Stabilize (StableRec SrcSpan
rv)) ->
if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) Bool -> Bool -> Bool
|| Ctxt -> Bool
allowRecursion GetCtxt
Ctxt
?ctxt then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
"It appears in a local recursive definition (at " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
rv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
")"
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
", which is not stable.")
Just (Stabilize StableReason
StableBox) ->
if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
"It occurs under " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
keyword SDoc
"box" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
", which is not stable.")
Just HiddenReason
AdvApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope: It occurs under adv.")
Just HiddenReason
SelectApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope: It occurs under select.")
Just HiddenReason
DelayApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope due to repeated application of delay")
Just HiddenReason
FunDef -> if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
", and is bound outside delay")
Maybe HiddenReason
Nothing
| (NoTickReason -> Bool)
-> (NonEmpty (Set Var) -> Bool)
-> Either NoTickReason (NonEmpty (Set Var))
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> NoTickReason -> Bool
forall a b. a -> b -> a
const Bool
False) ((Set Var -> Bool) -> NonEmpty (Set Var) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v)) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
Ctxt
?ctxt) ->
if Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v) then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
"It occurs under delay" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
", which is not stable.")
| Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v (Ctxt -> Set Var
current GetCtxt
Ctxt
?ctxt) -> VarScope
Visible
| Type -> Bool
isTemporal (Var -> Type
varType Var
v) Bool -> Bool -> Bool
&& Either NoTickReason (NonEmpty (Set Var)) -> Bool
forall a b. Either a b -> Bool
isRight (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
Ctxt
?ctxt) Bool -> Bool -> Bool
&& Var -> Bool
userFunction Var
v
-> VarScope
ImplUnboxed
| Bool
otherwise -> VarScope
Visible
primMap :: Map FastString Prim
primMap :: Map FastString Prim
primMap = [(FastString, Prim)] -> Map FastString Prim
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[(FastString
"Delay", Prim
Delay),
(FastString
"delay", Prim
Delay),
(FastString
"adv", Prim
Adv),
(FastString
"select", Prim
Select),
(FastString
"box", Prim
Box),
(FastString
"unbox", Prim
Unbox)]
isPrim :: GetCtxt => Var -> Maybe Prim
isPrim :: GetCtxt => Var -> Maybe Prim
isPrim Var
v
| Just Prim
p <- Var -> Map Var Prim -> Maybe Prim
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Map Var Prim
primAlias GetCtxt
Ctxt
?ctxt) = Prim -> Maybe Prim
forall a. a -> Maybe a
Just Prim
p
| Bool
otherwise = do
(FastString
name,FastString
mod) <- Var -> Maybe (FastString, FastString)
forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule Var
v
if FastString -> Bool
isRattModule FastString
mod then FastString -> Map FastString Prim -> Maybe Prim
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FastString
name Map FastString Prim
primMap
else Maybe Prim
forall a. Maybe a
Nothing
isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim,Var)
isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr (L SrcSpanAnnA
_ HsExpr GhcTc
e) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e where
isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var)
isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
v)) = (Prim -> (Prim, Var)) -> Maybe Prim -> Maybe (Prim, Var)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Var
v) (GetCtxt => Var -> Maybe Prim
Var -> Maybe Prim
isPrim Var
v)
#if __GLASGOW_HASKELL__ >= 906
isPrimExpr' (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsToken "@" GhcTc
_ LHsWcType (NoGhcTc GhcTc)
_) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#else
isPrimExpr' (HsAppType _ e _) = isPrimExpr e
#endif
isPrimExpr' (XExpr (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e))) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
isPrimExpr' (XExpr (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e))) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
isPrimExpr' (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#if __GLASGOW_HASKELL__ < 904
isPrimExpr' (HsTick _ _ e) = isPrimExpr e
isPrimExpr' (HsBinTick _ _ _ e) = isPrimExpr e
isPrimExpr' (HsPar _ e) = isPrimExpr e
#else
isPrimExpr' (XExpr (HsTick CoreTickish
_ LHsExpr GhcTc
e)) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
isPrimExpr' (XExpr (HsBinTick Int
_ Int
_ LHsExpr GhcTc
e)) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
isPrimExpr' (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ LHsExpr GhcTc
e LHsToken ")" GhcTc
_) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#endif
isPrimExpr' HsExpr GhcTc
_ = Maybe (Prim, Var)
forall a. Maybe a
Nothing
class NotSupported a where
notSupported :: GetCtxt => SDoc -> CheckM a
instance NotSupported Bool where
notSupported :: GetCtxt => SDoc -> CheckM Bool
notSupported SDoc
doc = GetCtxt => Severity -> SDoc -> CheckM Bool
Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"Asynchronous Rattus does not support " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
doc)
instance NotSupported (Bool,Set Var) where
notSupported :: GetCtxt => SDoc -> CheckM (Bool, Set Var)
notSupported SDoc
doc = (,Set Var
forall a. Set a
Set.empty) (Bool -> (Bool, Set Var)) -> CheckM Bool -> CheckM (Bool, Set Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SDoc -> CheckM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
doc
addVars :: Set Var -> Ctxt -> Ctxt
addVars :: Set Var -> Ctxt -> Ctxt
addVars Set Var
vs Ctxt
c = Ctxt
c{current = vs `Set.union` current c }
printMessage' :: GetCtxt => Severity -> SDoc -> CheckM ()
printMessage' :: GetCtxt => Severity -> SDoc -> CheckM ()
printMessage' Severity
sev SDoc
doc =
IO () -> CheckM ()
forall a.
IO a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ErrorMsgsRef -> ([ErrorMsg] -> [ErrorMsg]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Ctxt -> ErrorMsgsRef
errorMsgs GetCtxt
Ctxt
?ctxt) ((Severity
sev ,Ctxt -> SrcSpan
srcLoc GetCtxt
Ctxt
?ctxt, SDoc
doc) ErrorMsg -> [ErrorMsg] -> [ErrorMsg]
forall a. a -> [a] -> [a]
:))
printMessageCheck :: GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck :: GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
sev SDoc
doc = GetCtxt => Severity -> SDoc -> CheckM ()
Severity -> SDoc -> CheckM ()
printMessage' Severity
sev SDoc
doc CheckM () -> CheckM Bool -> CheckM Bool
forall a b.
StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
case Severity
sev of
Severity
SevError -> Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Severity
_ -> Bool -> CheckM Bool
forall a.
a
-> StateT [Maybe (Prim, SrcSpan)] (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True