{-# 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 = forall a. Set a
Set.empty,
earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left NoTickReason
NoDelay,
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 = forall k a. Map k a
Map.empty,
stableTypes :: Set Var
stableTypes = 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StableReason] -> ShowS
$cshowList :: [StableReason] -> ShowS
show :: StableReason -> String
$cshow :: StableReason -> String
showsPrec :: Int -> StableReason -> ShowS
$cshowsPrec :: Int -> StableReason -> ShowS
Show
data HiddenReason = Stabilize StableReason | FunDef | DelayApp | AdvApp | SelectApp deriving Int -> HiddenReason -> ShowS
[HiddenReason] -> ShowS
HiddenReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HiddenReason] -> ShowS
$cshowList :: [HiddenReason] -> ShowS
show :: HiddenReason -> String
$cshow :: HiddenReason -> String
showsPrec :: Int -> HiddenReason -> ShowS
$cshowsPrec :: Int -> HiddenReason -> ShowS
Show
data NoTickReason = NoDelay | TickHidden HiddenReason deriving Int -> NoTickReason -> ShowS
[NoTickReason] -> ShowS
NoTickReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoTickReason] -> ShowS
$cshowList :: [NoTickReason] -> ShowS
show :: NoTickReason -> String
$cshow :: NoTickReason -> String
showsPrec :: Int -> NoTickReason -> ShowS
$cshowsPrec :: Int -> NoTickReason -> ShowS
Show
type Hidden = Map Var HiddenReason
data Prim = Delay | Adv | Select | Box | Unbox deriving Int -> Prim -> ShowS
[Prim] -> ShowS
Prim -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prim] -> ShowS
$cshowList :: [Prim] -> ShowS
show :: Prim -> String
$cshow :: Prim -> String
showsPrec :: Int -> Prim -> ShowS
$cshowsPrec :: Int -> 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 = Ctxt
c in 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 in
let ?ctxt = Ctxt
newc in GetCtxt => a
a
getLocAnn' :: SrcSpanAnn' b -> SrcSpan
getLocAnn' :: forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' = 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 = forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
modifyCtxt (\Ctxt
c -> Ctxt
c {srcLoc :: SrcSpan
srcLoc = forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnn' b
src})
checkAll :: TcGblEnv -> TcM ()
checkAll :: TcGblEnv -> TcM ()
checkAll TcGblEnv
env = do
let dep :: [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dep = Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency (TcGblEnv -> Bag (LHsBindLR GhcTc GhcTc)
tcg_binds TcGblEnv
env)
let bindDep :: [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep = forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Bool
filterBinds (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dep
[(Bool, [ErrorMsg])]
result <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> TcM (Bool, [ErrorMsg])
checkSCC' (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep
let (Bool
res,[ErrorMsg]
msgs) = 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 forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
l')) (Bool
True,[]) [(Bool, [ErrorMsg])]
result
[ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs
if Bool
res then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure
printAccErrMsgs :: [ErrorMsg] -> TcM ()
printAccErrMsgs :: [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
(HasDynFlags m, MonadIO m, HasLogger m) =>
ErrorMsg -> m ()
printMsg (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) = forall (m :: * -> *).
(HasDynFlags m, MonadIO m, HasLogger m) =>
Severity -> SrcSpan -> SDoc -> m ()
printMessage Severity
sev SrcSpan
loc SDoc
doc
filterBinds :: Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Bool
filterBinds :: Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Bool
filterBinds 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)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar Set Var
vs
(CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
where checkVar :: Var -> Bool
checkVar :: Var -> Bool
checkVar Var
v =
let anns :: [AsyncRattus]
anns = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. name -> AnnTarget name
NamedTarget Name
name) :: [AsyncRattus]
annsMod :: [AsyncRattus]
annsMod = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [AsyncRattus]
name :: Name
name :: Name
name = Var -> Name
varName Var
v
in AsyncRattus
AsyncRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
anns Bool -> Bool -> Bool
|| (Bool -> Bool
not (AsyncRattus
NotAsyncRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
anns) Bool -> Bool -> Bool
&& AsyncRattus
AsyncRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
annsMod)
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 :: SrcSpan
srcLoc = SrcSpan
l}) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` 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) = forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check (forall a. Bag a -> [a]
bagToList Bag a
bs))
instance Scope a => Scope [a] where
check :: GetCtxt => [a] -> CheckM Bool
check [a]
ls = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 (forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
ps) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` 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 (forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
ps) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` 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} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XRec GhcTc [LMatch 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} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XRec GhcTc [LMatch 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
_) = ( , forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
p
let c' :: Ctxt
c' = Set Var -> Ctxt -> Ctxt
addVars Set Var
vs GetCtxt
?ctxt
Bool
r <- forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c' (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b)
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
_) = ( , forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b
checkBind (LetStmt XLetStmt GhcTc GhcTc a
_ HsLocalBindsLR GhcTc GhcTc
bs) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
checkBind ParStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"monad comprehensions"
checkBind TransStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"monad comprehensions"
checkBind ApplicativeStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"applicative do notation"
checkBind RecStmt{} = 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,forall a. Set a
Set.empty)
checkBind (a
x:[a]
xs) = do
(Bool
r,Set Var
vs) <- 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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [a]
xs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r',Set Var
vs 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 :: SrcSpan
srcLoc = SrcSpan
l}) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` 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) = forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l forall a b. (a -> b) -> a -> b
$ 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) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [GuardLStmt GhcTc]
gs
Bool
r' <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b)
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 = 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
checkPatBind LHsBindLR GhcTc GhcTc
b) (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsBindLR 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) = forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnnA
l forall a b. (a -> b) -> a -> b
$ GetCtxt => 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 ()
printMessage' Severity
SevError (SDoc
"(Mutual) recursive pattern binding definitions are not supported in Asynchronous Rattus")
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
#if __GLASGOW_HASKELL__ < 904
checkPatBind' AbsBinds {abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds} =
#else
checkPatBind' (XHsBindsLR AbsBinds {abs_binds = binds}) =
#endif
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind (forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
binds))
checkPatBind' HsBindLR GhcTc GhcTc
_ = 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
check' [LHsBindLR GhcTc GhcTc]
bs)
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 (forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
fc :: SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l Ctxt
c = let
ctxHid :: Set Var
ctxHid = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Var
current = forall a. Set a
Set.empty,
earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left (HiddenReason -> NoTickReason
TickHidden forall a b. (a -> b) -> a -> b
$ StableReason -> HiddenReason
Stabilize forall a b. (a -> b) -> a -> b
$ SrcSpan -> StableReason
StableRec SrcSpan
l),
hidden :: Hidden
hidden = Ctxt -> Hidden
hidden Ctxt
c forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
(forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const (StableReason -> HiddenReason
Stabilize (SrcSpan -> StableReason
StableRec SrcSpan
l))) Set Var
ctxHid),
recDef :: Maybe RecDef
recDef = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just (Set Var
vs,SrcSpan
l)) (\(Set Var
vs',SrcSpan
_) -> forall a. a -> Maybe a
Just (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Var
vs' Set Var
vs,SrcSpan
l)) (Ctxt -> Maybe RecDef
recDef Ctxt
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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
checkRecursiveBinds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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]
_) = 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]
_)) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds
instance ScopeBind (HsBindLR GhcTc GhcTc) where
checkBind :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind HsBindLR GhcTc GhcTc
b = (, forall a. HasBV a => a -> Set Var
getBV HsBindLR GhcTc GhcTc
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall {p} {l} {idR}.
(XRec p (IdP p) ~ GenLocated l Var, IdP p ~ Var,
HasBV (XRec p (HsBindLR p p)), HasBV (XRec p (Pat p))) =>
HsBindLR p idR -> Set Var
getAllBV' HsBindLR GhcTc GhcTc
b where
getAllBV' :: HsBindLR p idR -> Set Var
getAllBV' (FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L l
_ Var
v}) = forall a. a -> Set a
Set.singleton Var
v
#if __GLASGOW_HASKELL__ < 904
getAllBV' (AbsBinds {abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport p]
es, abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds p
bs}) = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall p. ABExport p -> IdP p
abe_poly [ABExport p]
es) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HasBV a => a -> Set Var
getBV LHsBinds p
bs
getAllBV' XHsBindsLR{} = forall a. Set a
Set.empty
#else
getAllBV' (XHsBindsLR (AbsBinds {abs_exports = es, abs_binds = bs})) = Set.fromList (map abe_poly es) `Set.union` foldMap getBV bs
#endif
getAllBV' (PatBind {pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec p (Pat p)
pat}) = forall a. HasBV a => a -> Set Var
getBV XRec p (Pat p)
pat
getAllBV' (VarBind {var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP p
v}) = forall a. a -> Set a
Set.singleton IdP p
v
getAllBV' PatSynBind{} = 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) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind forall a b. (a -> b) -> a -> b
$ 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)
checkRecursiveBinds [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall l. GenLocated l (HsBindLR GhcTc GhcTc) -> Set Var
getAllBV [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs')
where bs' :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' = 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) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsValBindsLR GhcTc GhcTc
bs
checkBind HsIPBinds {} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"implicit parameters"
checkBind EmptyLocalBinds{} = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,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) <- 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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rhs)
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) <- 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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
rhs)
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 = 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 a. Outputable a => a -> SDoc
ppr SrcSpan
src SDoc -> SDoc -> SDoc
<> SDoc
")"
isSelect :: GetCtxt => LHsExpr GhcTc -> Bool
isSelect :: GetCtxt => LHsExpr GhcTc -> Bool
isSelect LHsExpr GhcTc
e =
case GetCtxt => 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
isPrim Var
v =
case Prim
p of
Prim
Unbox -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Prim
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"Defining an alias for " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is not allowed")
| Bool
otherwise = case GetCtxt => Var -> VarScope
getScope Var
v of
Hidden SDoc
reason -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
reason
VarScope
Visible -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
VarScope
ImplUnboxed -> 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
isSelect LHsExpr GhcTc
f =
case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt of
Right (Set Var
er :| [Set Var]
ers) -> do
[Maybe (Prim, SrcSpan)]
res <- 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
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 forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre
Bool
b1 <- Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
arg
Bool
b2 <- Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
arg2
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. a -> Maybe a
Just (Prim
Select, Ctxt -> SrcSpan
srcLoc GetCtxt
?ctxt) forall a. a -> [a] -> [a]
:)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
b1 Bool -> Bool -> Bool
&& Bool
b2
[Maybe (Prim, SrcSpan)]
_ -> forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c{earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Set Var]
ers of
Maybe (NonEmpty (Set Var))
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
SelectApp
Just NonEmpty (Set Var)
ers' -> forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
current :: Set Var
current = Set Var
er,
hidden :: Hidden
hidden = Ctxt -> Hidden
hidden GetCtxt
?ctxt forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
SelectApp) (Ctxt -> Set Var
current GetCtxt
?ctxt)}
Left NoTickReason
NoDelay -> GetCtxt => 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
printMessageCheck Severity
SevError (SDoc
"select may only be used in the scope of a delay. "
SDoc -> SDoc -> SDoc
<> SDoc
" There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
<> SDoc
".")
check (HsApp XApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
case GetCtxt => 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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
Prim
Unbox -> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
Prim
Delay -> do forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
:)
Bool
b <- (\Ctxt
c -> Ctxt
c{current :: Set Var
current = forall a. Set a
Set.empty,
earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c of
Left NoTickReason
_ -> forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c forall a. a -> [a] -> NonEmpty a
:| [])
Right NonEmpty (Set Var)
cs -> forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (Set Var)
cs)})
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
[Maybe (Prim, SrcSpan)]
res <- 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
printMessageCheck Severity
SevError SDoc
"No adv or select found in the scope of this occurrence of delay"
Maybe (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
pre -> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
[Maybe (Prim, SrcSpan)]
_ -> forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
Prim
Adv -> case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt of
Right (Set Var
er :| [Set Var]
ers) -> do
[Maybe (Prim, SrcSpan)]
res <- 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
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 forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre
Bool
b <- Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. a -> Maybe a
Just (Prim
Adv,Ctxt -> SrcSpan
srcLoc GetCtxt
?ctxt) forall a. a -> [a] -> [a]
:)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
[Maybe (Prim, SrcSpan)]
_ -> forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c{earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Set Var]
ers of
Maybe (NonEmpty (Set Var))
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
AdvApp
Just NonEmpty (Set Var)
ers' -> forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
current :: Set Var
current = Set Var
er,
hidden :: Hidden
hidden = Ctxt -> Hidden
hidden GetCtxt
?ctxt forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
AdvApp) (Ctxt -> Set Var
current GetCtxt
?ctxt)}
Left NoTickReason
NoDelay -> GetCtxt => 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
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay. "
SDoc -> SDoc -> SDoc
<> SDoc
" There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
<> SDoc
".")
Prim
Select -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"select must be fully applied")
Maybe (Prim, Var)
_ -> forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1) (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2)
check HsUnboundVar{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if __GLASGOW_HASKELL__ >= 904
check (HsPar _ _ e _) = check e
check (HsLamCase _ _ mg) = check mg
check HsRecSel{} = return True
check HsTypedBracket{} = notSupported "MetaHaskell"
check HsUntypedBracket{} = notSupported "MetaHaskell"
#else
check HsConLikeOut{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsRecFld{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
check HsBracket{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
check (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check HsRnBracketOut{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
check HsTcBracketOut{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
#endif
#if __GLASGOW_HASKELL__ >= 904
check (HsLet _ _ bs _ e) = do
#else
check (HsLet XLet GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsExpr GhcTc
e) = do
#endif
(Bool
l,Set Var
vs) <- 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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
check HsOverLabel{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsIPVar{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"implicit parameters"
check HsOverLit{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check HsLit{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
check (OpApp XOpApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
check (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
check (HsCase XCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsExpr GhcTc)
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
e2
check (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
check (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
check (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
e Boxity
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [HsTupArg GhcTc]
e
check (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (HsMultiIf XMultiIf GhcTc
_ [LGRHS GhcTc (LHsExpr GhcTc)]
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (LHsExpr GhcTc)]
e
check (ExplicitList XExplicitList GhcTc
_ [LHsExpr GhcTc]
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc]
e
check HsProjection {} = 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} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr 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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
fs
check RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
f} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsRecordBinds GhcTc
f
check (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ ArithSeqInfo GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check ArithSeqInfo GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
check HsTypedSplice{} = notSupported "Template Haskell"
check HsUntypedSplice{} = notSupported "Template Haskell"
#else
check HsSpliceE{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"Template Haskell"
#endif
check (HsProc XProc GhcTc
_ LPat GhcTc
_ LHsCmdTop GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmdTop GhcTc
e
check (HsStatic XStatic GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (HsDo XDo GhcTc
_ HsStmtContext (HsDoRn GhcTc)
_ XRec GhcTc [GuardLStmt GhcTc]
e) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind XRec GhcTc [GuardLStmt GhcTc]
e
check (XExpr XXExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XXExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
check (HsAppType _ e _ _) = check e
check (ExprWithTySig _ e _) = check e
#else
check (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
#endif
check (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (HsIf XIf GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
instance (Scope a, Scope b) => Scope (Either a b) where
check :: GetCtxt => Either a b -> CheckM Bool
check (Left a
x) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x
check (Right b
x) = 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)) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsExpr GhcTc
e
check (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e)) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 904
check ConLikeTc{} = return True
check (HsTick _ e) = check e
check (HsBinTick _ _ e) = check e
#endif
instance Scope (HsCmdTop GhcTc) where
check :: GetCtxt => HsCmdTop GhcTc -> CheckM Bool
check (HsCmdTop XCmdTop GhcTc
_ LHsCmd GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd 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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
check (HsCmdDo XCmdDo GhcTc
_ XRec GhcTc [CmdLStmt GhcTc]
e) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind XRec GhcTc [CmdLStmt GhcTc]
e
check (HsCmdArrForm XCmdArrForm GhcTc
_ LHsExpr GhcTc
e1 LexicalFixity
_ Maybe Fixity
_ [LHsCmdTop GhcTc]
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsCmdTop GhcTc]
e2
check (HsCmdApp XCmdApp GhcTc
_ LHsCmd GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
check (HsCmdLam XCmdLam GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e
#if __GLASGOW_HASKELL__ >= 904
check (HsCmdPar _ _ e _) = check e
check (HsCmdLamCase _ _ e) = check e
check (HsCmdLet _ _ bs _ e) = do
#else
check (HsCmdPar XCmdPar GhcTc
_ LHsCmd GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e
check (HsCmdLamCase XCmdLamCase GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e
check (HsCmdLet XCmdLet GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsCmd GhcTc
e) = do
#endif
(Bool
l,Set Var
vs) <- 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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e)
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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e2
check (HsCmdIf XCmdIf GhcTc
_ SyntaxExpr GhcTc
_ LHsExpr GhcTc
e1 LHsCmd GhcTc
e2 LHsCmd GhcTc
e3) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e3
check (XCmd (HsWrap HsWrapper
_ HsCmd GhcTc
e)) = 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) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
check (FromTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
check (FromThenTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr 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} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsRecField GhcTc a]
fs
#if __GLASGOW_HASKELL__ >= 904
instance Scope b => Scope (HsFieldBind a b) where
check HsFieldBind{hfbRHS = a} = check a
#else
instance Scope b => Scope (HsRecField' a b) where
check :: GetCtxt => HsRecField' a b -> CheckM Bool
check HsRecField{hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = b
a} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check b
a
#endif
instance Scope (HsTupArg GhcTc) where
check :: GetCtxt => HsTupArg GhcTc -> CheckM Bool
check (Present XPresent GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
check Missing{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
instance Scope (HsBindLR GhcTc GhcTc) where
#if __GLASGOW_HASKELL__ >= 904
check (XHsBindsLR AbsBinds {abs_binds = binds, abs_ev_vars = ev})
#else
check :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
check AbsBinds {abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Var]
abs_ev_vars = [Var]
ev}
#endif
= Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check Bag (LHsBindLR GhcTc GhcTc)
binds
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes :: Set Var
stableTypes= Ctxt -> Set Var
stableTypes Ctxt
c forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe Var
isStableConstr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
varType) [Var]
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 forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
matches
where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes :: Set Var
stableTypes= Ctxt -> Set Var
stableTypes Ctxt
c forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
forall a. Ord a => [a] -> Set a
Set.fromList (HsWrapper -> [Var]
stableConstrFromWrapper' XFunBind GhcTc GhcTc
wrapper) forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
forall a. Ord a => [a] -> Set a
Set.fromList (Type -> [Var]
extractStableConstr (Var -> Type
varType Var
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 (forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
lhs) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (LHsExpr GhcTc)
rhs
check VarBind{var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
rhs} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
rhs
check PatSynBind {} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isStableConstr :: Type -> Maybe TyVar
isStableConstr :: Type -> Maybe Var
isStableConstr Type
t =
case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
Just (TyCon
con,[Type
args]) ->
case 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 forall a. Eq a => a -> a -> Bool
== FastString
"Stable"
then (Type -> Maybe Var
getTyVar_maybe Type
args)
else forall a. Maybe a
Nothing
Maybe (FastString, FastString)
_ -> forall a. Maybe a
Nothing
Maybe (TyCon, [Type])
_ -> forall a. Maybe a
Nothing
#if __GLASGOW_HASKELL__ >= 906
stableConstrFromWrapper' :: (HsWrapper , a) -> [TyVar]
stableConstrFromWrapper' (x , _) = stableConstrFromWrapper x
#else
stableConstrFromWrapper' :: HsWrapper -> [TyVar]
stableConstrFromWrapper' :: HsWrapper -> [Var]
stableConstrFromWrapper' = HsWrapper -> [Var]
stableConstrFromWrapper
#endif
stableConstrFromWrapper :: HsWrapper -> [TyVar]
stableConstrFromWrapper :: HsWrapper -> [Var]
stableConstrFromWrapper (WpCompose HsWrapper
v HsWrapper
w) = HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
v forall a. [a] -> [a] -> [a]
++ HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
w
stableConstrFromWrapper (WpEvLam Var
v) = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Type -> Maybe Var
isStableConstr (Var -> Type
varType Var
v)
stableConstrFromWrapper HsWrapper
_ = []
extractStableConstr :: Type -> [TyVar]
= forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Var
isStableConstr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
irrelevantMult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Scaled Type], Type)
splitFunTys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd 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
_)) = forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l
getSCCLoc (CyclicSCC ((L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_,Set Var
_ ) : [(LHsBindLR GhcTc GhcTc, Set Var)]
_)) = 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)
-> TcM (Bool, [ErrorMsg])
checkSCC' Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc = do
ErrorMsgsRef
err <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (IORef a)
newIORef [])
let allowRec :: Bool
allowRec = AsyncRattus
AllowRecursion forall a. Ord a => a -> Set a -> Bool
`Set.member` 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef ErrorMsgsRef
err)
let anns :: Set InternalAnn
anns = 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
then if InternalAnn
ExpectError forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
then 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 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 forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, 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 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
then if Bool
res
then 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 forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[])
else 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)) -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ 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) -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set a
checkVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
where checkVar :: Var -> Set a
checkVar :: Var -> Set a
checkVar Var
v =
let anns :: [a]
anns = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. name -> AnnTarget name
NamedTarget Name
name) :: [a]
annsMod :: [a]
annsMod = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [a]
name :: Name
name :: Name
name = Var -> Name
varName Var
v
in forall a. Ord a => [a] -> Set a
Set.fromList [a]
anns forall a. Ord a => Set a -> Set a -> Set a
`Set.union` 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
_)) = forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
errm forall a. Maybe a
Nothing Bool
allowRec) (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsBindLR GhcTc GhcTc
b) [])
checkSCC Bool
allowRec ErrorMsgsRef
errm (CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs'))
where bs' :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
vs :: Set Var
vs = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd [(LHsBindLR 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
_) = forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
errm (forall a. a -> Maybe a
Just (Set Var
vs,forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l)) Bool
allowRec) (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b) [])
stabilize :: StableReason -> Ctxt -> Ctxt
stabilize :: StableReason -> Ctxt -> Ctxt
stabilize StableReason
sr Ctxt
c = Ctxt
c
{current :: Set Var
current = forall a. Set a
Set.empty,
earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
hr,
hidden :: Hidden
hidden = Ctxt -> Hidden
hidden Ctxt
c forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
hr) Set Var
ctxHid}
where ctxHid :: Set Var
ctxHid = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 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 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 a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> 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 a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" must occur in the scope of a delay. "
SDoc -> SDoc -> SDoc
<> SDoc
"There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
<> SDoc
".")
Ctxt
_ -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Hidden
hidden GetCtxt
?ctxt) of
Just (Stabilize (StableRec SrcSpan
rv)) ->
if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v)) Bool -> Bool -> Bool
|| Ctxt -> Bool
allowRecursion GetCtxt
?ctxt then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
$$
SDoc
"It appears in a local recursive definition (at " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr SrcSpan
rv SDoc -> SDoc -> SDoc
<> SDoc
")"
SDoc -> SDoc -> SDoc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
Just (Stabilize StableReason
StableBox) ->
if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
$$
SDoc
"It occurs under " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
keyword SDoc
"box" SDoc -> SDoc -> SDoc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
Just HiddenReason
AdvApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope: It occurs under adv.")
Just HiddenReason
SelectApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope: It occurs under select.")
Just HiddenReason
DelayApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> 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) (Var -> Type
varType Var
v)) then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> 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 a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", and is bound outside delay")
Maybe HiddenReason
Nothing
| forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member Var
v)) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt) ->
if Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v) then VarScope
Visible
else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
$$
SDoc
"It occurs under delay" SDoc -> SDoc -> SDoc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
| forall a. Ord a => a -> Set a -> Bool
Set.member Var
v (Ctxt -> Set Var
current GetCtxt
?ctxt) -> VarScope
Visible
| Type -> Bool
isTemporal (Var -> Type
varType Var
v) Bool -> Bool -> Bool
&& forall a b. Either a b -> Bool
isRight (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt) Bool -> Bool -> Bool
&& Var -> Bool
userFunction Var
v
-> VarScope
ImplUnboxed
| Bool
otherwise -> VarScope
Visible
primMap :: Map FastString Prim
primMap :: Map FastString Prim
primMap = 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Map Var Prim
primAlias GetCtxt
?ctxt) = forall a. a -> Maybe a
Just Prim
p
| Bool
otherwise = do
(FastString
name,FastString
mod) <- forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule Var
v
if FastString -> Bool
isRattModule FastString
mod then forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FastString
name Map FastString Prim
primMap
else 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)
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)) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Var
v) (GetCtxt => Var -> Maybe Prim
isPrim Var
v)
#if __GLASGOW_HASKELL__ >= 906
isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e
#else
isPrimExpr' (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#endif
isPrimExpr' (XExpr (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e))) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
isPrimExpr' (XExpr (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e))) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
isPrimExpr' (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#if __GLASGOW_HASKELL__ < 904
isPrimExpr' (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
isPrimExpr' (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
isPrimExpr' (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#else
isPrimExpr' (XExpr (HsTick _ e)) = isPrimExpr e
isPrimExpr' (XExpr (HsBinTick _ _ e)) = isPrimExpr e
isPrimExpr' (HsPar _ _ e _) = isPrimExpr e
#endif
isPrimExpr' HsExpr GhcTc
_ = 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
printMessageCheck Severity
SevError (SDoc
"Asynchronous Rattus does not support " SDoc -> SDoc -> SDoc
<> SDoc
doc)
instance NotSupported (Bool,Set Var) where
notSupported :: GetCtxt => SDoc -> CheckM (Bool, Set Var)
notSupported SDoc
doc = (,forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: Set Var
current = Set Var
vs forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Ctxt -> Set Var
current Ctxt
c }
printMessage' :: GetCtxt => Severity -> SDoc -> CheckM ()
printMessage' :: GetCtxt => Severity -> SDoc -> CheckM ()
printMessage' Severity
sev SDoc
doc =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Ctxt -> ErrorMsgsRef
errorMsgs GetCtxt
?ctxt) ((Severity
sev ,Ctxt -> SrcSpan
srcLoc GetCtxt
?ctxt, SDoc
doc) 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 ()
printMessage' Severity
sev SDoc
doc forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
case Severity
sev of
Severity
SevError -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Severity
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True