{-# 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 =  forall a. Set a
Set.empty,
         earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left NoTickReason
NoDelay,
         hidden :: Hidden
hidden = forall k a. Map k a
Map.empty,
         srcLoc :: SrcSpan
srcLoc = SrcSpan
noLocationInfo,
         recDef :: Maybe RecDef
recDef = Maybe RecDef
mvar,
         primAlias :: Map Var Prim
primAlias = forall k a. Map k a
Map.empty,
         stableTypes :: Set Var
stableTypes = forall a. Set a
Set.empty,
         allowRecursion :: Bool
allowRecursion = Bool
allowRec}

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StableReason] -> ShowS
$cshowList :: [StableReason] -> ShowS
show :: StableReason -> String
$cshow :: StableReason -> String
showsPrec :: Int -> StableReason -> ShowS
$cshowsPrec :: Int -> StableReason -> ShowS
Show

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HiddenReason] -> ShowS
$cshowList :: [HiddenReason] -> ShowS
show :: HiddenReason -> String
$cshow :: HiddenReason -> String
showsPrec :: Int -> HiddenReason -> ShowS
$cshowsPrec :: Int -> HiddenReason -> ShowS
Show

-- | Indicates, why there is no tick
data NoTickReason = NoDelay | TickHidden HiddenReason deriving Int -> NoTickReason -> ShowS
[NoTickReason] -> ShowS
NoTickReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoTickReason] -> ShowS
$cshowList :: [NoTickReason] -> ShowS
show :: NoTickReason -> String
$cshow :: NoTickReason -> String
showsPrec :: Int -> NoTickReason -> ShowS
$cshowsPrec :: Int -> NoTickReason -> ShowS
Show

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prim] -> ShowS
$cshowList :: [Prim] -> ShowS
show :: Prim -> String
$cshow :: Prim -> String
showsPrec :: Int -> Prim -> ShowS
$cshowsPrec :: Int -> Prim -> ShowS
Show

-- | 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 = Ctxt
c in 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 in
  let ?ctxt = Ctxt
newc in GetCtxt => a
a




getLocAnn' :: SrcSpanAnn' b -> SrcSpan
getLocAnn' :: forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' = forall b. SrcSpanAnn' b -> SrcSpan
locA


updateLoc :: SrcSpanAnn' b -> (GetCtxt => a) -> (GetCtxt => a)
updateLoc :: forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
src = forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
modifyCtxt (\Ctxt
c -> Ctxt
c {srcLoc :: SrcSpan
srcLoc = forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnn' b
src})


-- | 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 dep :: [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dep = Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency (TcGblEnv -> Bag (LHsBindLR GhcTc GhcTc)
tcg_binds TcGblEnv
env)
  let bindDep :: [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep = forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Bool
filterBinds (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dep
  [(Bool, [ErrorMsg])]
result <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> TcM (Bool, [ErrorMsg])
checkSCC' (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep
  let (Bool
res,[ErrorMsg]
msgs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Bool
b,[ErrorMsg]
l) (Bool
b',[ErrorMsg]
l') -> (Bool
b Bool -> Bool -> Bool
&& Bool
b', [ErrorMsg]
l forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
l')) (Bool
True,[]) [(Bool, [ErrorMsg])]
result
  [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs
  if Bool
res then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure


printAccErrMsgs :: [ErrorMsg] -> TcM ()
printAccErrMsgs :: [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}.
(HasDynFlags m, MonadIO m, HasLogger m) =>
ErrorMsg -> m ()
printMsg (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Severity
_,SrcSpan
l,SDoc
_)->SrcSpan
l) [ErrorMsg]
msgs)
  where printMsg :: ErrorMsg -> m ()
printMsg (Severity
sev,SrcSpan
loc,SDoc
doc) = forall (m :: * -> *).
(HasDynFlags m, MonadIO m, HasLogger m) =>
Severity -> SrcSpan -> SDoc -> m ()
printMessage Severity
sev SrcSpan
loc SDoc
doc


-- | This function checks whether a given top-level definition (either
-- a single non-recursive definition or a group of mutual recursive
-- definitions) is marked as Asynchronous Rattus code (via an annotation). In a
-- group of mutual recursive definitions, the whole group is
-- considered Asynchronous Rattus code if at least one of its constituents is
-- marked as such.
filterBinds :: Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> Bool
filterBinds :: Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Bool
filterBinds Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc =
  case SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc of
    (AcyclicSCC (LHsBindLR GhcTc GhcTc
_,Set Var
vs)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar Set Var
vs
    (CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
  where checkVar :: Var -> Bool
        checkVar :: Var -> Bool
checkVar Var
v =
          let anns :: [AsyncRattus]
anns = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. name -> AnnTarget name
NamedTarget Name
name) :: [AsyncRattus]
              annsMod :: [AsyncRattus]
annsMod = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [AsyncRattus]
              name :: Name
              name :: Name
name = Var -> Name
varName Var
v
          in AsyncRattus
AsyncRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
anns Bool -> Bool -> Bool
|| (Bool -> Bool
not (AsyncRattus
NotAsyncRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
anns)  Bool -> Bool -> Bool
&& AsyncRattus
AsyncRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
annsMod)



instance Scope a => Scope (GenLocated SrcSpan a) where
  check :: GetCtxt => GenLocated SrcSpan a -> CheckM Bool
check (L SrcSpan
l a
x) =  (\Ctxt
c -> Ctxt
c {srcLoc :: SrcSpan
srcLoc = SrcSpan
l}) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x

instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where
  check :: GetCtxt => GenLocated (SrcSpanAnn' b) a -> CheckM Bool
check (L SrcSpanAnn' b
l a
x) =  forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l forall a b. (a -> b) -> a -> b
$ forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x
  
instance Scope a => Scope (Bag a) where
  check :: GetCtxt => Bag a -> CheckM Bool
check Bag a
bs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check (forall a. Bag a -> [a]
bagToList Bag a
bs))

instance Scope a => Scope [a] where
  check :: GetCtxt => [a] -> CheckM Bool
check [a]
ls = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [a]
ls)


instance Scope (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
  check :: GetCtxt =>
Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> CheckM Bool
check Match{m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[LPat GhcTc]
ps,m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs} = Set Var -> Ctxt -> Ctxt
addVars (forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
ps) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs

instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
  check :: GetCtxt =>
Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> CheckM Bool
check Match{m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[LPat GhcTc]
ps,m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
rhs} = Set Var -> Ctxt -> Ctxt
addVars (forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
ps) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
rhs


instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
  check :: GetCtxt =>
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> CheckM Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
alts} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
alts


instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
  check :: GetCtxt =>
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
-> CheckM Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
alts} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
alts


instance Scope a => ScopeBind (StmtLR GhcTc GhcTc a) where
  checkBind :: GetCtxt => StmtLR GhcTc GhcTc a -> CheckM (Bool, Set Var)
checkBind (LastStmt XLastStmt GhcTc GhcTc a
_ a
b Maybe Bool
_ SyntaxExpr GhcTc
_) =  ( , forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b
  checkBind (BindStmt XBindStmt GhcTc GhcTc a
_ LPat GhcTc
p a
b) = do
    let vs :: Set Var
vs = forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
p
    let c' :: Ctxt
c' = Set Var -> Ctxt -> Ctxt
addVars Set Var
vs GetCtxt
?ctxt
    Bool
r <- forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c' (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r,Set Var
vs)
  checkBind (BodyStmt XBodyStmt GhcTc GhcTc a
_ a
b SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_) = ( , forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b
  checkBind (LetStmt XLetStmt GhcTc GhcTc a
_ HsLocalBindsLR GhcTc GhcTc
bs) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
  checkBind ParStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"monad comprehensions"
  checkBind TransStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"monad comprehensions"
  checkBind ApplicativeStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"applicative do notation"
  checkBind RecStmt{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"recursive do notation"

instance ScopeBind a => ScopeBind [a] where
  checkBind :: GetCtxt => [a] -> CheckM (Bool, Set Var)
checkBind [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,forall a. Set a
Set.empty)
  checkBind (a
x:[a]
xs) = do
    (Bool
r,Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind a
x
    (Bool
r',Set Var
vs') <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [a]
xs)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r',Set Var
vs forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Var
vs')

instance ScopeBind a => ScopeBind (GenLocated SrcSpan a) where
  checkBind :: GetCtxt => GenLocated SrcSpan a -> CheckM (Bool, Set Var)
checkBind (L SrcSpan
l a
x) =  (\Ctxt
c -> Ctxt
c {srcLoc :: SrcSpan
srcLoc = SrcSpan
l}) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind a
x

instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where
  checkBind :: GetCtxt => GenLocated (SrcSpanAnn' b) a -> CheckM (Bool, Set Var)
checkBind (L SrcSpanAnn' b
l a
x) =  forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l forall a b. (a -> b) -> a -> b
$ forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind a
x

instance Scope a => Scope (GRHS GhcTc a) where
  check :: GetCtxt => GRHS GhcTc a -> CheckM Bool
check (GRHS XCGRHS GhcTc a
_ [GuardLStmt GhcTc]
gs a
b) = do
    (Bool
r, Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [GuardLStmt GhcTc]
gs
    Bool
r' <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt`  (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
b)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r')

checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec LHsBindLR GhcTc GhcTc
b =  forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind LHsBindLR GhcTc GhcTc
b) (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsBindLR GhcTc GhcTc
b)

checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind (L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
b) = forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnnA
l forall a b. (a -> b) -> a -> b
$ GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind' HsBindLR GhcTc GhcTc
b

checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind' PatBind{} = do
  GetCtxt => Severity -> SDoc -> CheckM ()
printMessage' Severity
SevError (SDoc
"(Mutual) recursive pattern binding definitions are not supported in Asynchronous Rattus")
  forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
#if __GLASGOW_HASKELL__ < 904
checkPatBind' AbsBinds {abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds} = 
#else
checkPatBind' (XHsBindsLR AbsBinds {abs_binds = binds}) = 
#endif
  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkPatBind (forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
binds))

checkPatBind' HsBindLR GhcTc GhcTc
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


-- | 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 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
check' [LHsBindLR GhcTc GhcTc]
bs)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, Set Var
vs)
    where check' :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> CheckM Bool
check' b :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b@(L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_) = SrcSpan -> Ctxt -> Ctxt
fc (forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
          fc :: SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l Ctxt
c = let
            ctxHid :: Set Var
ctxHid = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c)
            in Ctxt
c {current :: Set Var
current = forall a. Set a
Set.empty,
                  earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left (HiddenReason -> NoTickReason
TickHidden forall a b. (a -> b) -> a -> b
$ StableReason -> HiddenReason
Stabilize forall a b. (a -> b) -> a -> b
$ SrcSpan -> StableReason
StableRec SrcSpan
l),
                  hidden :: Hidden
hidden =  Ctxt -> Hidden
hidden Ctxt
c forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                            (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const (StableReason -> HiddenReason
Stabilize (SrcSpan -> StableReason
StableRec SrcSpan
l))) Set Var
ctxHid),
                  recDef :: Maybe RecDef
recDef = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just (Set Var
vs,SrcSpan
l)) (\(Set Var
vs',SrcSpan
_) -> forall a. a -> Maybe a
Just (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Var
vs' Set Var
vs,SrcSpan
l)) (Ctxt -> Maybe RecDef
recDef Ctxt
c)
                   -- 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
  checkBind (CyclicSCC [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) = GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
checkRecursiveBinds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs)
  
instance ScopeBind (HsValBindsLR GhcTc GhcTc) where
  checkBind :: GetCtxt => HsValBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind (ValBinds XValBinds GhcTc GhcTc
_ Bag (LHsBindLR GhcTc GhcTc)
bs [LSig GhcTc]
_) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind (Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency Bag (LHsBindLR GhcTc GhcTc)
bs)
  
  checkBind (XValBindsLR (NValBinds [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds [LSig GhcRn]
_)) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds


instance ScopeBind (HsBindLR GhcTc GhcTc) where
  checkBind :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind HsBindLR GhcTc GhcTc
b = (, forall a. HasBV a => a -> Set Var
getBV HsBindLR GhcTc GhcTc
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsBindLR GhcTc GhcTc
b


-- | 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) = forall {p} {l} {idR}.
(XRec p (IdP p) ~ GenLocated l Var, IdP p ~ Var,
 HasBV (XRec p (HsBindLR p p)), HasBV (XRec p (Pat p))) =>
HsBindLR p idR -> Set Var
getAllBV' HsBindLR GhcTc GhcTc
b where
  getAllBV' :: HsBindLR p idR -> Set Var
getAllBV' (FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L l
_ Var
v}) = forall a. a -> Set a
Set.singleton Var
v
#if __GLASGOW_HASKELL__ < 904
  getAllBV' (AbsBinds {abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport p]
es, abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds p
bs}) = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall p. ABExport p -> IdP p
abe_poly [ABExport p]
es) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. HasBV a => a -> Set Var
getBV LHsBinds p
bs
  getAllBV' XHsBindsLR{} = forall a. Set a
Set.empty
#else
  getAllBV' (XHsBindsLR (AbsBinds {abs_exports = es, abs_binds = bs})) = Set.fromList (map abe_poly es) `Set.union` foldMap getBV bs
#endif
  getAllBV' (PatBind {pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec p (Pat p)
pat}) = forall a. HasBV a => a -> Set Var
getBV XRec p (Pat p)
pat
  getAllBV' (VarBind {var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP p
v}) = forall a. a -> Set a
Set.singleton IdP p
v
  getAllBV' PatSynBind{} = forall a. Set a
Set.empty


-- 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)  = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs
  checkBind (RecFlag
Recursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs) = GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> CheckM (Bool, Set Var)
checkRecursiveBinds [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall l. GenLocated l (HsBindLR GhcTc GhcTc) -> Set Var
getAllBV [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs')
    where bs' :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' = forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bs


instance ScopeBind (HsLocalBindsLR GhcTc GhcTc) where
  checkBind :: GetCtxt => HsLocalBindsLR GhcTc GhcTc -> CheckM (Bool, Set Var)
checkBind (HsValBinds XHsValBinds GhcTc GhcTc
_ HsValBindsLR GhcTc GhcTc
bs) = forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsValBindsLR GhcTc GhcTc
bs
  checkBind HsIPBinds {} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"implicit parameters"
  checkBind EmptyLocalBinds{} = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,forall a. Set a
Set.empty)

type SrcAnno = SrcSpanAnnA
  
instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
  check :: GetCtxt =>
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> CheckM Bool
check GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rhs, grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds = HsLocalBindsLR GhcTc GhcTc
lbinds} = do
    (Bool
l,Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
lbinds
    Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
rhs)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)

instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
  check :: GetCtxt =>
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> CheckM Bool
check GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
rhs, grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds = HsLocalBindsLR GhcTc GhcTc
lbinds} = do
    (Bool
l,Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
lbinds
    Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
rhs)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)

instance Show Var where
  show :: Var -> String
show Var
v = forall a. NamedThing a => a -> String
getOccString Var
v


tickHidden :: HiddenReason -> SDoc
tickHidden :: HiddenReason -> SDoc
tickHidden HiddenReason
FunDef = SDoc
"a function definition"
tickHidden HiddenReason
DelayApp = SDoc
"a nested application of delay"
tickHidden HiddenReason
AdvApp = SDoc
"an application of adv"
tickHidden HiddenReason
SelectApp = SDoc
"an application of select"
tickHidden (Stabilize StableReason
StableBox) = SDoc
"an application of box"
tickHidden (Stabilize (StableRec SrcSpan
src)) = SDoc
"a nested recursive definition (at " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr SrcSpan
src SDoc -> SDoc -> SDoc
<> SDoc
")"

isSelect :: GetCtxt => LHsExpr GhcTc -> Bool
isSelect :: GetCtxt => LHsExpr GhcTc -> Bool
isSelect LHsExpr GhcTc
e =
  case GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e of
    Just (Prim
Select, Var
_) -> Bool
True
    Maybe (Prim, Var)
_ -> Bool
False

instance Scope (HsExpr GhcTc) where
  check :: GetCtxt => HsExpr GhcTc -> CheckM Bool
check (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
v))
    | Just Prim
p <- GetCtxt => Var -> Maybe Prim
isPrim Var
v =
        case Prim
p of
          Prim
Unbox -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Prim
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"Defining an alias for " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is not allowed")
    | Bool
otherwise = case GetCtxt => Var -> VarScope
getScope Var
v of
             Hidden SDoc
reason -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
reason
             VarScope
Visible -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             VarScope
ImplUnboxed -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               -- 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
isSelect LHsExpr GhcTc
f =
    case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt of
      Right (Set Var
er :| [Set Var]
ers) -> do
        [Maybe (Prim, SrcSpan)]
res <- forall (m :: * -> *) s. Monad m => StateT s m s
get
        case [Maybe (Prim, SrcSpan)]
res of
            Just (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"only one adv or select may be used in the scope of a delay.")
            Maybe (Prim, SrcSpan)
Nothing : [Maybe (Prim, SrcSpan)]
pre -> do forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre
                                Bool
b1 <- Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
arg
                                Bool
b2 <- Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
arg2
                                forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. a -> Maybe a
Just (Prim
Select, Ctxt -> SrcSpan
srcLoc GetCtxt
?ctxt) forall a. a -> [a] -> [a]
:)
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
b1 Bool -> Bool -> Bool
&& Bool
b2
            [Maybe (Prim, SrcSpan)]
_ -> forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
        where mod :: Ctxt -> Ctxt
mod Ctxt
c =  Ctxt
c{earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Set Var]
ers of
                                    Maybe (NonEmpty (Set Var))
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
SelectApp
                                    Just NonEmpty (Set Var)
ers' -> forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
                        current :: Set Var
current = Set Var
er,
                        hidden :: Hidden
hidden = Ctxt -> Hidden
hidden GetCtxt
?ctxt forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                        forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
SelectApp) (Ctxt -> Set Var
current GetCtxt
?ctxt)}
      Left NoTickReason
NoDelay -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
"select may only be used in the scope of a delay."
      Left (TickHidden HiddenReason
hr) -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"select may only be used in the scope of a delay. "
                        SDoc -> SDoc -> SDoc
<> SDoc
" There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
<> SDoc
".")
  check (HsApp XApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
    case GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e1 of
    Just (Prim
p,Var
_) -> case Prim
p of
      Prim
Box -> do
        Bool
ch <- StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableBox forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
      Prim
Unbox -> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
      Prim
Delay -> do forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
:)
                  Bool
b <- (\Ctxt
c -> Ctxt
c{current :: Set Var
current = forall a. Set a
Set.empty,
                           earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c of
                                      Left NoTickReason
_ -> forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c forall a. a -> [a] -> NonEmpty a
:| [])
                                      Right NonEmpty (Set Var)
cs -> forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (Set Var)
cs)})
                     forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
                  [Maybe (Prim, SrcSpan)]
res <- forall (m :: * -> *) s. Monad m => StateT s m s
get
                  case [Maybe (Prim, SrcSpan)]
res of
                    Maybe (Prim, SrcSpan)
Nothing : [Maybe (Prim, SrcSpan)]
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError SDoc
"No adv or select found in the scope of this occurrence of delay"
                    Maybe (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
pre -> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
                    [Maybe (Prim, SrcSpan)]
_ -> forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
      Prim
Adv -> case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt of
        Right (Set Var
er :| [Set Var]
ers) -> do
          [Maybe (Prim, SrcSpan)]
res <- forall (m :: * -> *) s. Monad m => StateT s m s
get
          case [Maybe (Prim, SrcSpan)]
res of
            Just (Prim, SrcSpan)
_ : [Maybe (Prim, SrcSpan)]
_ -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"only one adv or select may be used in the scope of a delay.")
            Maybe (Prim, SrcSpan)
Nothing : [Maybe (Prim, SrcSpan)]
pre -> do forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Maybe (Prim, SrcSpan)]
pre
                                Bool
b <- Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
                                forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. a -> Maybe a
Just (Prim
Adv,Ctxt -> SrcSpan
srcLoc GetCtxt
?ctxt) forall a. a -> [a] -> [a]
:)
                                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
            [Maybe (Prim, SrcSpan)]
_ -> forall a. HasCallStack => String -> a
error String
"Asynchronous Rattus: internal error"
          where mod :: Ctxt -> Ctxt
mod Ctxt
c =  Ctxt
c{earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Set Var]
ers of
                                       Maybe (NonEmpty (Set Var))
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
AdvApp
                                       Just NonEmpty (Set Var)
ers' -> forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
                           current :: Set Var
current = Set Var
er,
                           hidden :: Hidden
hidden = Ctxt -> Hidden
hidden GetCtxt
?ctxt forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                            forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
AdvApp) (Ctxt -> Set Var
current GetCtxt
?ctxt)}
        Left NoTickReason
NoDelay -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay.")
        Left (TickHidden HiddenReason
hr) -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay. "
                            SDoc -> SDoc -> SDoc
<> SDoc
" There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
<> SDoc
".")
      Prim
Select -> GetCtxt => Severity -> SDoc -> CheckM Bool
printMessageCheck Severity
SevError (SDoc
"select must be fully applied")
    Maybe (Prim, Var)
_ -> forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1)  (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2)
  check HsUnboundVar{}  = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if __GLASGOW_HASKELL__ >= 904
  check (HsPar _ _ e _) = check e
  check (HsLamCase _ _ mg) = check mg
  check HsRecSel{} = return True
  check HsTypedBracket{} = notSupported "MetaHaskell"
  check HsUntypedBracket{} = notSupported "MetaHaskell"
#else
  check HsConLikeOut{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsRecFld{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check HsBracket{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
  check (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check HsRnBracketOut{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
  check HsTcBracketOut{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"MetaHaskell"
#endif
#if __GLASGOW_HASKELL__ >= 904
  check (HsLet _ _ bs _ e) = do
#else
  check (HsLet XLet GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsExpr GhcTc
e) = do
#endif
    (Bool
l,Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
    Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
         
  check HsOverLabel{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsIPVar{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"implicit parameters"
  check HsOverLit{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True  
  check HsLit{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check (OpApp XOpApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
  check (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check (HsCase XCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsExpr GhcTc)
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
e2
  check (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
  check (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
  check (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
e Boxity
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [HsTupArg GhcTc]
e
  check (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (HsMultiIf XMultiIf GhcTc
_ [LGRHS GhcTc (LHsExpr GhcTc)]
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LGRHS GhcTc (LHsExpr GhcTc)]
e
  check (ExplicitList XExplicitList GhcTc
_ [LHsExpr GhcTc]
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc]
e
  check HsProjection {} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsGetField {gf_expr :: forall p. HsExpr p -> LHsExpr p
gf_expr = LHsExpr GhcTc
e} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
fs} = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
fs
  check RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
f} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsRecordBinds GhcTc
f
  check (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ ArithSeqInfo GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check ArithSeqInfo GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
  check HsTypedSplice{} = notSupported "Template Haskell"
  check HsUntypedSplice{} = notSupported "Template Haskell"
#else
  check HsSpliceE{} = forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
"Template Haskell"
#endif
  check (HsProc XProc GhcTc
_ LPat GhcTc
_ LHsCmdTop GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmdTop GhcTc
e
  check (HsStatic XStatic GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (HsDo XDo GhcTc
_ HsStmtContext (HsDoRn GhcTc)
_ XRec GhcTc [GuardLStmt GhcTc]
e) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind XRec GhcTc [GuardLStmt GhcTc]
e
  check (XExpr XXExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check XXExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
  check (HsAppType _ e _ _) = check e
  check (ExprWithTySig _ e _) = check e
#else
  check (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
#endif
  check (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (HsIf XIf GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]


instance (Scope a, Scope b) => Scope (Either a b) where
  check :: GetCtxt => Either a b -> CheckM Bool
check (Left a
x) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check a
x
  check (Right b
x) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check b
x


#if __GLASGOW_HASKELL__ >= 908
instance Scope (LHsRecUpdFields GhcTc) where
  check RegularRecUpdFields {recUpdFields = x} = check x
  check OverloadedRecUpdFields {olRecUpdFields = x} = check x
#endif


instance Scope XXExprGhcTc where
  check :: GetCtxt => XXExprGhcTc -> CheckM Bool
check (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e)) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsExpr GhcTc
e
  check (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e)) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 904
  check ConLikeTc{} = return True
  check (HsTick _ e) = check e
  check (HsBinTick _ _ e) = check e
#endif

instance Scope (HsCmdTop GhcTc) where
  check :: GetCtxt => HsCmdTop GhcTc -> CheckM Bool
check (HsCmdTop XCmdTop GhcTc
_ LHsCmd GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e
  
instance Scope (HsCmd GhcTc) where
  check :: GetCtxt => HsCmd GhcTc -> CheckM Bool
check (HsCmdArrApp XCmdArrApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
_ Bool
_) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
  check (HsCmdDo XCmdDo GhcTc
_ XRec GhcTc [CmdLStmt GhcTc]
e) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind XRec GhcTc [CmdLStmt GhcTc]
e
  check (HsCmdArrForm XCmdArrForm GhcTc
_ LHsExpr GhcTc
e1 LexicalFixity
_ Maybe Fixity
_ [LHsCmdTop GhcTc]
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsCmdTop GhcTc]
e2
  check (HsCmdApp XCmdApp GhcTc
_ LHsCmd GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
  check (HsCmdLam XCmdLam GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e
#if __GLASGOW_HASKELL__ >= 904
  check (HsCmdPar _ _ e _) = check e
  check (HsCmdLamCase _ _ e) = check e  
  check (HsCmdLet _ _ bs _ e) = do
#else
  check (HsCmdPar XCmdPar GhcTc
_ LHsCmd GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e
  check (HsCmdLamCase XCmdLamCase GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e
  check (HsCmdLet XCmdLet GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsCmd GhcTc
e) = do
#endif
    (Bool
l,Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> CheckM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
    Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)

  check (HsCmdCase XCmdCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsCmd GhcTc)
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e2
  check (HsCmdIf XCmdIf GhcTc
_ SyntaxExpr GhcTc
_ LHsExpr GhcTc
e1 LHsCmd GhcTc
e2 LHsCmd GhcTc
e3) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsCmd GhcTc
e3
  check (XCmd (HsWrap HsWrapper
_ HsCmd GhcTc
e)) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check HsCmd GhcTc
e


instance Scope (ArithSeqInfo GhcTc) where
  check :: GetCtxt => ArithSeqInfo GhcTc -> CheckM Bool
check (From LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check (FromThen LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
  check (FromTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2
  check (FromThenTo LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e3

instance Scope a => Scope (HsRecFields GhcTc a) where
  check :: GetCtxt => HsRecFields GhcTc a -> CheckM Bool
check HsRecFields {rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc a]
fs} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check [LHsRecField GhcTc a]
fs



#if __GLASGOW_HASKELL__ >= 904
instance Scope b => Scope (HsFieldBind a b) where
  check HsFieldBind{hfbRHS = a} = check a
#else
instance Scope b => Scope (HsRecField' a b) where
  check :: GetCtxt => HsRecField' a b -> CheckM Bool
check HsRecField{hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = b
a} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check b
a
#endif

instance Scope (HsTupArg GhcTc) where
  check :: GetCtxt => HsTupArg GhcTc -> CheckM Bool
check (Present XPresent GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
e
  check Missing{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

instance Scope (HsBindLR GhcTc GhcTc) where
#if __GLASGOW_HASKELL__ >= 904
  check (XHsBindsLR AbsBinds {abs_binds = binds, abs_ev_vars  = ev})
#else
  check :: GetCtxt => HsBindLR GhcTc GhcTc -> CheckM Bool
check AbsBinds {abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Var]
abs_ev_vars  = [Var]
ev}
#endif
    = Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check Bag (LHsBindLR GhcTc GhcTc)
binds
      where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes :: Set Var
stableTypes= Ctxt -> Set Var
stableTypes Ctxt
c forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                        forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe Var
isStableConstr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
varType) [Var]
ev)}
  check FunBind{fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches= MatchGroup GhcTc (LHsExpr GhcTc)
matches, fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Var
v,
                fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcTc GhcTc
wrapper} =
      Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
matches
    where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes :: Set Var
stableTypes= Ctxt -> Set Var
stableTypes Ctxt
c forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                      forall a. Ord a => [a] -> Set a
Set.fromList (HsWrapper -> [Var]
stableConstrFromWrapper' XFunBind GhcTc GhcTc
wrapper)  forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                      forall a. Ord a => [a] -> Set a
Set.fromList (Type -> [Var]
extractStableConstr (Var -> Type
varType Var
v))}
  check PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
lhs, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs=GRHSs GhcTc (LHsExpr GhcTc)
rhs} = Set Var -> Ctxt -> Ctxt
addVars (forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
lhs) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check GRHSs GhcTc (LHsExpr GhcTc)
rhs
  check VarBind{var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
rhs} = forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsExpr GhcTc
rhs
  check PatSynBind {} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- 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 HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
    Just (TyCon
con,[Type
args]) ->
      case forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule TyCon
con of
        Just (FastString
name, FastString
mod) ->
          if FastString -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Stable"
          then (Type -> Maybe Var
getTyVar_maybe Type
args)
          else forall a. Maybe a
Nothing
        Maybe (FastString, FastString)
_ -> forall a. Maybe a
Nothing                           
    Maybe (TyCon, [Type])
_ ->  forall a. Maybe a
Nothing



#if __GLASGOW_HASKELL__ >= 906
stableConstrFromWrapper' :: (HsWrapper , a) -> [TyVar]
stableConstrFromWrapper' (x , _) = stableConstrFromWrapper x
#else
stableConstrFromWrapper' :: HsWrapper -> [TyVar]
stableConstrFromWrapper' :: HsWrapper -> [Var]
stableConstrFromWrapper' = HsWrapper -> [Var]
stableConstrFromWrapper
#endif

stableConstrFromWrapper :: HsWrapper -> [TyVar]
stableConstrFromWrapper :: HsWrapper -> [Var]
stableConstrFromWrapper (WpCompose HsWrapper
v HsWrapper
w) = HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
v forall a. [a] -> [a] -> [a]
++ HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
w
stableConstrFromWrapper (WpEvLam Var
v) = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Type -> Maybe Var
isStableConstr (Var -> Type
varType Var
v)
stableConstrFromWrapper HsWrapper
_ = []


-- | 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  = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Var
isStableConstr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
irrelevantMult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Scaled Type], Type)
splitFunTys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Var], Type)
splitForAllTys'


getSCCLoc :: SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc (AcyclicSCC (L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_ ,Set Var
_)) = forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l
getSCCLoc (CyclicSCC ((L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_,Set Var
_ ) : [(LHsBindLR GhcTc GhcTc, Set Var)]
_)) = forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
_ = SrcSpan
noLocationInfo

checkSCC' ::  Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg])
checkSCC' :: Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> TcM (Bool, [ErrorMsg])
checkSCC' Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc = do
  ErrorMsgsRef
err <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (IORef a)
newIORef [])
  let allowRec :: Bool
allowRec = AsyncRattus
AllowRecursion forall a. Ord a => a -> Set a -> Bool
`Set.member` forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
  Bool
res <- Bool
-> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool
checkSCC Bool
allowRec ErrorMsgsRef
err SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
  [ErrorMsg]
msgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef ErrorMsgsRef
err)
  let anns :: Set InternalAnn
anns = forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
  if InternalAnn
ExpectWarning forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns 
    then if InternalAnn
ExpectError forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
         then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Annotation to expect both warning and error is not allowed.")])
         else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
True; Severity
_ -> Bool
False) [ErrorMsg]
msgs
              then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, forall a. (a -> Bool) -> [a] -> [a]
filter (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
False; Severity
_ -> Bool
True) [ErrorMsg]
msgs)
              else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Warning was expected, but typechecking produced no warning.")])
    else if InternalAnn
ExpectError forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
         then if Bool
res
              then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Error was expected, but typechecking produced no error.")])
              else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[])
         else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, [ErrorMsg]
msgs)
getAnn :: forall a . (Data a, Ord a) => Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> Set a
getAnn :: forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc =
  case SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc of
    (AcyclicSCC (LHsBindLR GhcTc GhcTc
_,Set Var
vs)) -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set a
checkVar Set Var
vs
    (CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set a
checkVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
  where checkVar :: Var -> Set a
        checkVar :: Var -> Set a
checkVar Var
v =
          let anns :: [a]
anns = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. name -> AnnTarget name
NamedTarget Name
name) :: [a]
              annsMod :: [a]
annsMod = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [a]
              name :: Name
              name :: Name
name = Var -> Name
varName Var
v
          in forall a. Ord a => [a] -> Set a
Set.fromList [a]
anns forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a. Ord a => [a] -> Set a
Set.fromList [a]
annsMod



-- | 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
_)) = forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
errm forall a. Maybe a
Nothing Bool
allowRec) (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall a. (Scope a, GetCtxt) => a -> CheckM Bool
check LHsBindLR GhcTc GhcTc
b) [])

checkSCC Bool
allowRec ErrorMsgsRef
errm (CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs'))
  where bs' :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bs' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
        vs :: Set Var
vs = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
        check' :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' b :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b@(L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_) = forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
errm (forall a. a -> Maybe a
Just (Set Var
vs,forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l)) Bool
allowRec) (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool
checkRec GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b) [])

-- | 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 Var
current = forall a. Set a
Set.empty,
   earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
hr,
   hidden :: Hidden
hidden = Ctxt -> Hidden
hidden Ctxt
c forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
hr) Set Var
ctxHid}
  where ctxHid :: Set Var
ctxHid = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c)) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c)
        hr :: HiddenReason
hr = StableReason -> HiddenReason
Stabilize StableReason
sr

data VarScope = Hidden SDoc | Visible | ImplUnboxed


-- | This function checks whether the given variable is in scope.
getScope  :: GetCtxt => Var -> VarScope
getScope :: GetCtxt => Var -> VarScope
getScope Var
v =
  case GetCtxt
?ctxt of
    Ctxt{recDef :: Ctxt -> Maybe RecDef
recDef = Just (Set Var
vs,SrcSpan
_), earlier :: Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier = Either NoTickReason (NonEmpty (Set Var))
e, allowRecursion :: Ctxt -> Bool
allowRecursion = Bool
allowRec} | Var
v forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Var
vs ->
     if Bool
allowRec then VarScope
Visible else
        case Either NoTickReason (NonEmpty (Set Var))
e of
          Right NonEmpty (Set Var)
_ -> VarScope
Visible
          Left NoTickReason
NoDelay -> SDoc -> VarScope
Hidden (SDoc
"The (mutually) recursive call to " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" must occur in the scope of a delay")
          Left (TickHidden HiddenReason
hr) -> SDoc -> VarScope
Hidden (SDoc
"The (mutually) recursive call to " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" must occur in the scope of a delay. "
                            SDoc -> SDoc -> SDoc
<> SDoc
"There is a delay, but its scope is interrupted by " SDoc -> SDoc -> SDoc
<> HiddenReason -> SDoc
tickHidden HiddenReason
hr SDoc -> SDoc -> SDoc
<> SDoc
".")
    Ctxt
_ ->  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Hidden
hidden GetCtxt
?ctxt) of
            Just (Stabilize (StableRec SrcSpan
rv)) ->
              if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v)) Bool -> Bool -> Bool
|| Ctxt -> Bool
allowRecursion GetCtxt
?ctxt then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
$$
                       SDoc
"It appears in a local recursive definition (at " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr SrcSpan
rv SDoc -> SDoc -> SDoc
<> SDoc
")"
                       SDoc -> SDoc -> SDoc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
            Just (Stabilize StableReason
StableBox) ->
              if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
$$
                       SDoc
"It occurs under " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
keyword SDoc
"box" SDoc -> SDoc -> SDoc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
            Just HiddenReason
AdvApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope: It occurs under adv.")
            Just HiddenReason
SelectApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope: It occurs under select.")
            Just HiddenReason
DelayApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope due to repeated application of delay")
            Just HiddenReason
FunDef -> if (Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", and is bound outside delay")
            Maybe HiddenReason
Nothing
              | forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
Set.member Var
v)) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt) ->
                if Set Var -> Type -> Bool
isStable (Ctxt -> Set Var
stableTypes GetCtxt
?ctxt) (Var -> Type
varType Var
v) then VarScope
Visible
                else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is no longer in scope:" SDoc -> SDoc -> SDoc
$$
                         SDoc
"It occurs under delay" SDoc -> SDoc -> SDoc
$$ SDoc
"and is of type " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
              | forall a. Ord a => a -> Set a -> Bool
Set.member Var
v (Ctxt -> Set Var
current GetCtxt
?ctxt) -> VarScope
Visible
              | Type -> Bool
isTemporal (Var -> Type
varType Var
v) Bool -> Bool -> Bool
&& forall a b. Either a b -> Bool
isRight (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt) Bool -> Bool -> Bool
&& Var -> Bool
userFunction Var
v
                -> VarScope
ImplUnboxed
              | Bool
otherwise -> VarScope
Visible

-- | A map from the syntax of a primitive of Asynchronous Rattus to 'Prim'.
primMap :: Map FastString Prim
primMap :: Map FastString Prim
primMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [(FastString
"Delay", Prim
Delay),
   (FastString
"delay", Prim
Delay),
   (FastString
"adv", Prim
Adv),
   (FastString
"select", Prim
Select),
   (FastString
"box", Prim
Box),
   (FastString
"unbox", Prim
Unbox)]


-- | 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Map Var Prim
primAlias GetCtxt
?ctxt) = forall a. a -> Maybe a
Just Prim
p
  | Bool
otherwise = do
  (FastString
name,FastString
mod) <- forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule Var
v
  if FastString -> Bool
isRattModule FastString
mod then forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FastString
name Map FastString Prim
primMap
  else forall a. Maybe a
Nothing


-- | 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)
isPrimExpr' HsExpr GhcTc
e where
  isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var)
  isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
v)) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Var
v) (GetCtxt => Var -> Maybe Prim
isPrim Var
v)
#if __GLASGOW_HASKELL__ >= 906
  isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e
#else
  isPrimExpr' (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#endif

  isPrimExpr' (XExpr (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e))) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
  isPrimExpr' (XExpr (ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
e))) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
  isPrimExpr' (HsPragE XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#if __GLASGOW_HASKELL__ < 904
  isPrimExpr' (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  isPrimExpr' (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  isPrimExpr' (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#else
  isPrimExpr' (XExpr (HsTick _ e)) = isPrimExpr e
  isPrimExpr' (XExpr (HsBinTick _ _ e)) = isPrimExpr e
  isPrimExpr' (HsPar _ _ e _) = isPrimExpr e
#endif

  isPrimExpr' HsExpr GhcTc
_ = forall a. Maybe a
Nothing


-- | 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
printMessageCheck Severity
SevError (SDoc
"Asynchronous Rattus does not support " SDoc -> SDoc -> SDoc
<> SDoc
doc)

instance NotSupported (Bool,Set Var) where
  notSupported :: GetCtxt => SDoc -> CheckM (Bool, Set Var)
notSupported SDoc
doc = (,forall a. Set a
Set.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (NotSupported a, GetCtxt) => SDoc -> CheckM a
notSupported SDoc
doc


-- | 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 :: Set Var
current = Set Var
vs forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Ctxt -> Set Var
current Ctxt
c }

-- | Print a message with the current location.
printMessage' :: GetCtxt => Severity -> SDoc ->  CheckM ()
printMessage' :: GetCtxt => Severity -> SDoc -> CheckM ()
printMessage' Severity
sev SDoc
doc =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (Ctxt -> ErrorMsgsRef
errorMsgs GetCtxt
?ctxt) ((Severity
sev ,Ctxt -> SrcSpan
srcLoc GetCtxt
?ctxt, SDoc
doc) forall a. a -> [a] -> [a]
:))

-- | 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 ()
printMessage' Severity
sev SDoc
doc forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  case Severity
sev of
    Severity
SevError -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Severity
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True