{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}



-- | This module implements the source plugin that checks the variable
-- scope of of Async Rattus programs.

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]

-- | The current context for scope checking
data Ctxt = Ctxt
  {
    Ctxt -> ErrorMsgsRef
errorMsgs :: ErrorMsgsRef,
    -- | Variables that are in scope now (i.e. occurring in the typing
    -- context but not to the left of a tick)
    Ctxt -> Set Var
current :: LCtxt,
    -- | Variables that are in the typing context, but to the left of a
    -- tick
    Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier :: Either NoTickReason (NonEmpty LCtxt),
    -- | Variables that have fallen out of scope. The map contains the
    -- reason why they have fallen out of scope.
    Ctxt -> Hidden
hidden :: Hidden,
    -- -- | Same as 'hidden' but for recursive variables.
    -- hiddenRec :: Hidden,
    -- | The current location information.
    Ctxt -> SrcSpan
srcLoc :: SrcSpan,
    -- | If we are in the body of a recursively defined function, this
    -- field contains the variables that are defined recursively
    -- (could be more than one due to mutual recursion or because of a
    -- recursive pattern definition) and the location of the recursive
    -- definition.
    Ctxt -> Maybe RecDef
recDef :: Maybe RecDef,
    -- | Type variables with a 'Stable' constraint attached to them.
    Ctxt -> Set Var
stableTypes :: Set Var,
    -- | A mapping from variables to the primitives that they are
    -- defined equal to. For example, a program could contain @let
    -- mydel = delay in mydel 1@, in which case @mydel@ is mapped to
    -- 'Delay'.
    Ctxt -> Map Var Prim
primAlias :: Map Var Prim,
    -- | Allow general recursion.
    Ctxt -> Bool
allowRecursion :: Bool}



-- | The starting context for checking a top-level definition. For
-- non-recursive definitions, the argument is @Nothing@. Otherwise, it
-- contains the recursively defined variables along with the location
-- of the recursive definition.
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}

-- | A local context, consisting of a set of variables.
type LCtxt = Set Var

-- | The recursively defined variables + the position where the
-- recursive definition starts
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

-- | Indicates, why a variable has fallen out of scope.
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

-- | Indicates, why there is no tick
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

-- | Hidden context, containing variables that have fallen out of
-- context along with the reason why they have.
type Hidden = Map Var HiddenReason

-- | The 5 primitive Asynchronous Rattus operations.
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

-- | This constraint is used to pass along the context implicitly via
-- an implicit parameter.
type GetCtxt = ?ctxt :: Ctxt


type CheckM = StateT ([Maybe (Prim, SrcSpan)]) TcM

-- | This type class is implemented for each AST type @a@ for which we
-- can check whether it adheres to the scoping rules of Asynchronous Rattus.
class Scope a where
  -- | Check whether the argument is a scope correct piece of syntax
  -- in the given context.
  check :: GetCtxt => a -> CheckM Bool

-- | This is a variant of 'Scope' for syntax that can also bind
-- variables.
class ScopeBind a where
  -- | 'checkBind' checks whether its argument is scope-correct and in
  -- addition returns the the set of variables bound by it.
  checkBind :: GetCtxt => a -> CheckM (Bool,Set Var)


-- | set the current context.
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


-- | modify the current context.
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})


-- | Check all definitions in the given module. If Scope errors are
-- found, the current execution is halted with 'exitFailure'.
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


-- | Check the scope of a list of (mutual) recursive bindings. The
-- second argument is the set of variables defined by the (mutual)
-- recursive bindings
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)
                   -- TODO fix location info of recDef (needs one location for each var)
                   }          


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


-- | Compute the set of variables defined by the given Haskell binder.
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


-- Check nested bindings
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
               -- printMessageCheck SevWarning
               --  (ppr v <> text " is an external temporal function used under delay, which may cause time leaks.")
  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 -- pattern synonyms are not supported


-- | Checks whether the given type is a type constraint of the form
-- @Stable a@ for some type variable @a@. In that case it returns the
-- type variable @a@.
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
_ = []


-- | Given a type @(C1, ... Cn) => t@, this function returns the list
-- of type variables @[a1,...,am]@ for which there is a constraint
-- @Stable ai@ among @C1, ... Cn@.
extractStableConstr :: Type -> [TyVar]
extractStableConstr :: Type -> [Var]
extractStableConstr  = (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



-- | Checks a top-level definition group, which is either a single
-- non-recursive definition or a group of (mutual) recursive
-- definitions.

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) [])

-- | Stabilizes the given context, i.e. remove all non-stable types
-- and any tick. This is performed on checking 'box', and
-- guarded recursive definitions. To provide better error messages a
-- reason has to be given as well.
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


-- | This function checks whether the given variable is in scope.
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

-- | A map from the syntax of a primitive of Asynchronous Rattus to 'Prim'.
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)]


-- | Checks whether a given variable is in fact an Asynchronous Rattus primitive.
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


-- | Checks whether a given expression is in fact a Asynchronous Rattus primitive.
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


-- | This type class provides default implementations for 'check' and
-- 'checkBind' for Haskell syntax that is not supported. These default
-- implementations simply print an error message.
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


-- | Add variables to the current context.
addVars :: Set Var -> Ctxt -> Ctxt
addVars :: Set Var -> Ctxt -> Ctxt
addVars Set Var
vs Ctxt
c = Ctxt
c{current = vs `Set.union` current c }

-- | Print a message with the current location.
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]
:))

-- | Print a message with the current location. Returns 'False', if
-- the severity is 'SevError' and otherwise 'True.
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