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



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

module Rattus.Plugin.ScopeCheck (checkAll) where

import Rattus.Plugin.Utils
import Rattus.Plugin.Dependency
import Rattus.Plugin.Annotation

import Data.IORef

import Prelude hiding ((<>))
import GhcPlugins
import TcRnTypes
import Bag

#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs.Extension
import GHC.Hs.Expr
import GHC.Hs.Pat
import GHC.Hs.Binds
#else 
import HsExtension
import HsExpr
import HsPat
import HsBinds
#endif

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 System.Exit
import Data.Either
import Data.Maybe

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 -> LCtxt
current :: LCtxt,
    -- | Variables that are in the typing context, but to the left of a
    -- tick
    Ctxt -> Either NoTickReason LCtxt
earlier :: Either NoTickReason 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 -> LCtxt
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,
    -- | This flag indicates whether the context was 'stabilized'
    -- (stripped of all non-stable stuff). It is set when typechecking
    -- 'box', 'arr' and guarded recursion.
    Ctxt -> Maybe StableReason
stabilized :: Maybe StableReason}



-- | 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) -> Ctxt
emptyCtxt :: ErrorMsgsRef -> Maybe RecDef -> Ctxt
emptyCtxt ErrorMsgsRef
em Maybe RecDef
mvar =
  Ctxt :: ErrorMsgsRef
-> LCtxt
-> Either NoTickReason LCtxt
-> Hidden
-> SrcSpan
-> Maybe RecDef
-> LCtxt
-> Map Var Prim
-> Maybe StableReason
-> Ctxt
Ctxt { errorMsgs :: ErrorMsgsRef
errorMsgs = ErrorMsgsRef
em,
         current :: LCtxt
current =  LCtxt
forall a. Set a
Set.empty,
         earlier :: Either NoTickReason LCtxt
earlier = NoTickReason -> Either NoTickReason LCtxt
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 = FastString -> SrcSpan
UnhelpfulSpan FastString
"<no location info>",
         recDef :: Maybe RecDef
recDef = Maybe RecDef
mvar,
         primAlias :: Map Var Prim
primAlias = Map Var Prim
forall k a. Map k a
Map.empty,
         stableTypes :: LCtxt
stableTypes = LCtxt
forall a. Set a
Set.empty,
         stabilized :: Maybe StableReason
stabilized = case Maybe RecDef
mvar of
           Just (LCtxt
_,SrcSpan
loc) ->  StableReason -> Maybe StableReason
forall a. a -> Maybe a
Just (SrcSpan -> StableReason
StableRec SrcSpan
loc)
           Maybe RecDef
_  ->  Maybe StableReason
forall a. Maybe a
Nothing}

-- | 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 | StableArr 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
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 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
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
(Int -> NoTickReason -> ShowS)
-> (NoTickReason -> String)
-> ([NoTickReason] -> ShowS)
-> Show NoTickReason
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 4 primitive Rattus operations plus 'arr'.
data Prim = Delay | Adv | Box | Unbox | Arr 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
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


-- | This type class is implemented for each AST type @a@ for which we
-- can check whether it adheres to the scoping rules of Rattus.
class Scope a where
  -- | Check whether the argument is a scope correct piece of syntax
  -- in the given context.
  check :: GetCtxt => a -> TcM 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 -> TcM (Bool,Set Var)


-- | set the current context.
setCtxt :: Ctxt -> (GetCtxt => a) -> a 
setCtxt :: Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c GetCtxt => a
a = let ?ctxt = c in a
GetCtxt => a
a


-- | modify the current context.
modifyCtxt :: (Ctxt -> Ctxt) -> (GetCtxt => a) -> (GetCtxt => a)
modifyCtxt :: (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 = newc in a
GetCtxt => a
a


-- | 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, LCtxt)]
dep = Bag (LHsBindLR GhcTc GhcTc) -> [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
dependency (TcGblEnv -> Bag (LHsBindLR GhcTc GhcTc)
tcg_binds TcGblEnv
env)
  let bindDep :: [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
bindDep = (SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> Bool)
-> [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
-> [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> Bool
filterBinds (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
dep
  ErrorMsgsRef
err <- IO ErrorMsgsRef -> IOEnv (Env TcGblEnv TcLclEnv) ErrorMsgsRef
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([ErrorMsg] -> IO ErrorMsgsRef
forall a. a -> IO (IORef a)
newIORef [])
  [Bool]
res <- (SCC (LHsBindLR GhcTc GhcTc, LCtxt)
 -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ErrorMsgsRef
-> SCC (LHsBindLR GhcTc GhcTc, LCtxt)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
checkSCC ErrorMsgsRef
err) [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
bindDep
  [ErrorMsg]
msgs <- IO [ErrorMsg] -> IOEnv (Env TcGblEnv TcLclEnv) [ErrorMsg]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ErrorMsgsRef -> IO [ErrorMsg]
forall a. IORef a -> IO a
readIORef ErrorMsgsRef
err)
  [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs
  if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
res then () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IO () -> TcM ()
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) =>
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) =>
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 Rattus code (via an annotation). In a
-- group of mutual recursive definitions, the whole group is
-- considered 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, LCtxt) -> Bool
filterBinds Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc =
  case SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc of
    (AcyclicSCC (LHsBindLR GhcTc GhcTc
_,LCtxt
vs)) -> (Var -> Bool) -> LCtxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar LCtxt
vs
    (CyclicSCC [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs) -> ((LHsBindLR GhcTc GhcTc, LCtxt) -> Bool)
-> [(LHsBindLR GhcTc GhcTc, LCtxt)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Var -> Bool) -> LCtxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar (LCtxt -> Bool)
-> ((LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt)
-> (LHsBindLR GhcTc GhcTc, LCtxt)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt
forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs
  where checkVar :: Var -> Bool
        checkVar :: Var -> Bool
checkVar Var
v =
          let anns :: [Rattus]
anns = ([Word8] -> Rattus) -> AnnEnv -> CoreAnnTarget -> [Rattus]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> Rattus
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (Name -> CoreAnnTarget
forall name. name -> AnnTarget name
NamedTarget Name
name) :: [Rattus]
              annsMod :: [Rattus]
annsMod = ([Word8] -> Rattus) -> AnnEnv -> CoreAnnTarget -> [Rattus]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> Rattus
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (Module -> CoreAnnTarget
forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [Rattus]
              name :: Name
              name :: Name
name = Var -> Name
varName Var
v
          in Rattus
Rattus Rattus -> [Rattus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rattus]
anns Bool -> Bool -> Bool
|| (Bool -> Bool
not (Rattus
NotRattus Rattus -> [Rattus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rattus]
anns)  Bool -> Bool -> Bool
&& Rattus
Rattus Rattus -> [Rattus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rattus]
annsMod)


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


instance Scope (LHsBinds GhcTc) where
  check :: Bag (LHsBindLR GhcTc GhcTc) -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check Bag (LHsBindLR GhcTc GhcTc)
bs = ([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [LHsBindLR GhcTc GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check (Bag (LHsBindLR GhcTc GhcTc) -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
bs))

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


instance Scope a => Scope (Match GhcTc a) where
  check :: Match GhcTc a -> IOEnv (Env TcGblEnv TcLclEnv) 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 a
rhs} = Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check GRHSs GhcTc a
rhs
    where mod :: Ctxt -> Ctxt
mod Ctxt
c = LCtxt -> Ctxt -> Ctxt
addVars ([Located (Pat GhcTc)] -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV [LPat GhcTc]
[Located (Pat GhcTc)]
ps) (if [Located (Pat GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcTc]
[Located (Pat GhcTc)]
ps then Ctxt
c else HiddenReason -> Ctxt -> Ctxt
stabilizeLater HiddenReason
FunDef Ctxt
c)
  check XMatch{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

instance Scope a => Scope (MatchGroup GhcTc a) where
  check :: MatchGroup GhcTc a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = Located [LMatch GhcTc a]
alts} = Located [LMatch GhcTc a] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check Located [LMatch GhcTc a]
alts
  check XMatchGroup {} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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


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

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


instance Scope a => Scope (GRHS GhcTc a) where
  check :: GRHS GhcTc a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check (GRHS XCGRHS GhcTc a
_ [GuardLStmt GhcTc]
gs a
b) = do
    (Bool
r, LCtxt
vs) <- [GuardLStmt GhcTc] -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind [GuardLStmt GhcTc]
gs
    Bool
r' <- LCtxt -> Ctxt -> Ctxt
addVars LCtxt
vs (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt`  (a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check a
b)
    Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r')
  check XGRHS{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
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 -> TcM (Bool, Set Var)
checkRecursiveBinds :: [LHsBindLR GhcTc GhcTc] -> LCtxt -> TcM (Bool, LCtxt)
checkRecursiveBinds [LHsBindLR GhcTc GhcTc]
bs LCtxt
vs = do
    Bool
res <- ([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [LHsBindLR GhcTc GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check' [LHsBindLR GhcTc GhcTc]
bs)
    case Ctxt -> Maybe StableReason
stabilized GetCtxt
Ctxt
?ctxt of
      Just StableReason
reason | Bool
res ->
        (GetCtxt => Severity -> SDoc -> TcM ()
Severity -> SDoc -> TcM ()
printMessage' Severity
SevWarning (StableReason -> SDoc
recReason StableReason
reason SDoc -> SDoc -> SDoc
<> SDoc
" can cause time leaks")) TcM () -> TcM (Bool, LCtxt) -> TcM (Bool, LCtxt)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, LCtxt) -> TcM (Bool, LCtxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, LCtxt
vs)
      Maybe StableReason
_ -> (Bool, LCtxt) -> TcM (Bool, LCtxt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, LCtxt
vs)
    where check' :: LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check' b :: LHsBindLR GhcTc GhcTc
b@(L SrcSpan
l HsBindLR GhcTc GhcTc
_) = SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsBindLR GhcTc GhcTc
b
          fc :: SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l Ctxt
c = let
            ctxHid :: LCtxt
ctxHid = (NoTickReason -> LCtxt)
-> (LCtxt -> LCtxt) -> Either NoTickReason LCtxt -> LCtxt
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LCtxt -> NoTickReason -> LCtxt
forall a b. a -> b -> a
const (LCtxt -> NoTickReason -> LCtxt) -> LCtxt -> NoTickReason -> LCtxt
forall a b. (a -> b) -> a -> b
$ Ctxt -> LCtxt
current Ctxt
c) (LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> LCtxt
current Ctxt
c)) (Ctxt -> Either NoTickReason LCtxt
earlier Ctxt
c)
            in Ctxt
c {current :: LCtxt
current = LCtxt
forall a. Set a
Set.empty,
                  earlier :: Either NoTickReason LCtxt
earlier = NoTickReason -> Either NoTickReason LCtxt
forall a b. a -> Either a b
Left (HiddenReason -> NoTickReason
TickHidden (HiddenReason -> NoTickReason) -> HiddenReason -> NoTickReason
forall a b. (a -> b) -> a -> b
$ StableReason -> HiddenReason
Stabilize (StableReason -> HiddenReason) -> StableReason -> HiddenReason
forall a b. (a -> b) -> a -> b
$ SrcSpan -> StableReason
StableRec SrcSpan
l),
                  hidden :: Hidden
hidden =  Ctxt -> Hidden
hidden Ctxt
c Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                            ((Var -> HiddenReason) -> LCtxt -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const (StableReason -> HiddenReason
Stabilize (SrcSpan -> StableReason
StableRec SrcSpan
l))) LCtxt
ctxHid),
                  recDef :: Maybe RecDef
recDef = Maybe RecDef
-> (RecDef -> Maybe RecDef) -> Maybe RecDef -> Maybe RecDef
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RecDef -> Maybe RecDef
forall a. a -> Maybe a
Just (LCtxt
vs,SrcSpan
l)) (\(LCtxt
vs',SrcSpan
_) -> RecDef -> Maybe RecDef
forall a. a -> Maybe a
Just (LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
Set.union LCtxt
vs' LCtxt
vs,SrcSpan
l)) (Ctxt -> Maybe RecDef
recDef Ctxt
c),
                   -- TODO fix location info of recDef (needs one location for each var)
                  stabilized :: Maybe StableReason
stabilized = StableReason -> Maybe StableReason
forall a. a -> Maybe a
Just (SrcSpan -> StableReason
StableRec SrcSpan
l)}

          recReason :: StableReason -> SDoc
          recReason :: StableReason -> SDoc
recReason (StableRec SrcSpan
_) = SDoc
"nested recursive definitions"
          recReason StableReason
StableBox = SDoc
"recursive definitions nested under box"
          recReason StableReason
StableArr = SDoc
"recursive definitions nested under arr"



instance ScopeBind (SCC (LHsBindLR GhcTc GhcTc, Set Var)) where
  checkBind :: SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> TcM (Bool, LCtxt)
checkBind (AcyclicSCC (LHsBindLR GhcTc GhcTc
b,LCtxt
vs)) = (, LCtxt
vs) (Bool -> (Bool, LCtxt))
-> IOEnv (Env TcGblEnv TcLclEnv) Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsBindLR GhcTc GhcTc
b
  checkBind (CyclicSCC [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs) = GetCtxt => [LHsBindLR GhcTc GhcTc] -> LCtxt -> TcM (Bool, LCtxt)
[LHsBindLR GhcTc GhcTc] -> LCtxt -> TcM (Bool, LCtxt)
checkRecursiveBinds (((LHsBindLR GhcTc GhcTc, LCtxt) -> LHsBindLR GhcTc GhcTc)
-> [(LHsBindLR GhcTc GhcTc, LCtxt)] -> [LHsBindLR GhcTc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (LHsBindLR GhcTc GhcTc, LCtxt) -> LHsBindLR GhcTc GhcTc
forall a b. (a, b) -> a
fst [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs) (((LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt)
-> [(LHsBindLR GhcTc GhcTc, LCtxt)] -> LCtxt
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt
forall a b. (a, b) -> b
snd [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs)
  
instance ScopeBind (HsValBindsLR GhcTc GhcTc) where
  checkBind :: HsValBindsLR GhcTc GhcTc -> TcM (Bool, LCtxt)
checkBind (ValBinds XValBinds GhcTc GhcTc
_ Bag (LHsBindLR GhcTc GhcTc)
bs [LSig GhcTc]
_) = [SCC (LHsBindLR GhcTc GhcTc, LCtxt)] -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind (Bag (LHsBindLR GhcTc GhcTc) -> [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
dependency Bag (LHsBindLR GhcTc GhcTc)
bs)
  
  checkBind (XValBindsLR (NValBinds binds _)) = [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))] -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds


instance ScopeBind (HsBindLR GhcTc GhcTc) where
  checkBind :: HsBindLR GhcTc GhcTc -> TcM (Bool, LCtxt)
checkBind HsBindLR GhcTc GhcTc
b = (, HsBindLR GhcTc GhcTc -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV HsBindLR GhcTc GhcTc
b) (Bool -> (Bool, LCtxt))
-> IOEnv (Env TcGblEnv TcLclEnv) Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) 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 :: GenLocated l (HsBindLR GhcTc GhcTc) -> LCtxt
getAllBV (L l
_ HsBindLR GhcTc GhcTc
b) = HsBindLR GhcTc GhcTc -> LCtxt
forall p idR.
(HasBV (XRec p Pat), HasBV (HsBindLR p p), IdP p ~ Var) =>
HsBindLR p idR -> LCtxt
getAllBV' HsBindLR GhcTc GhcTc
b where
  getAllBV' :: HsBindLR p idR -> LCtxt
getAllBV' (FunBind{fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
_ IdP p
v}) = Var -> LCtxt
forall a. a -> Set a
Set.singleton IdP p
Var
v
  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}) = [Var] -> LCtxt
forall a. Ord a => [a] -> Set a
Set.fromList ((ABExport p -> Var) -> [ABExport p] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map ABExport p -> Var
forall p. ABExport p -> IdP p
abe_poly [ABExport p]
es) LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (LHsBindLR p p -> LCtxt) -> LHsBinds p -> LCtxt
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LHsBindLR p p -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV LHsBinds p
bs
  getAllBV' (PatBind {pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec p Pat
pat}) = XRec p Pat -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV XRec p Pat
pat
  getAllBV' (VarBind {var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP p
v}) = Var -> LCtxt
forall a. a -> Set a
Set.singleton IdP p
Var
v
  getAllBV' PatSynBind{} = LCtxt
forall a. Set a
Set.empty
  getAllBV' XHsBindsLR{} = LCtxt
forall a. Set a
Set.empty


-- Check nested bindings
instance ScopeBind (RecFlag, LHsBinds GhcTc) where
  checkBind :: (RecFlag, Bag (LHsBindLR GhcTc GhcTc)) -> TcM (Bool, LCtxt)
checkBind (RecFlag
NonRecursive, Bag (LHsBindLR GhcTc GhcTc)
bs)  = [LHsBindLR GhcTc GhcTc] -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind ([LHsBindLR GhcTc GhcTc] -> TcM (Bool, LCtxt))
-> [LHsBindLR GhcTc GhcTc] -> TcM (Bool, LCtxt)
forall a b. (a -> b) -> a -> b
$ Bag (LHsBindLR GhcTc GhcTc) -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
bs
  checkBind (RecFlag
Recursive, Bag (LHsBindLR GhcTc GhcTc)
bs) = GetCtxt => [LHsBindLR GhcTc GhcTc] -> LCtxt -> TcM (Bool, LCtxt)
[LHsBindLR GhcTc GhcTc] -> LCtxt -> TcM (Bool, LCtxt)
checkRecursiveBinds [LHsBindLR GhcTc GhcTc]
bs' ((LHsBindLR GhcTc GhcTc -> LCtxt)
-> [LHsBindLR GhcTc GhcTc] -> LCtxt
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LHsBindLR GhcTc GhcTc -> LCtxt
forall l. GenLocated l (HsBindLR GhcTc GhcTc) -> LCtxt
getAllBV [LHsBindLR GhcTc GhcTc]
bs')
    where bs' :: [LHsBindLR GhcTc GhcTc]
bs' = Bag (LHsBindLR GhcTc GhcTc) -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
bs


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

instance Scope a => Scope (GRHSs GhcTc a) where
  check :: GRHSs GhcTc a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check GRHSs{grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs = [LGRHS GhcTc a]
rhs, grhssLocalBinds :: forall p body. GRHSs p body -> LHsLocalBinds p
grhssLocalBinds = LHsLocalBindsLR GhcTc GhcTc
lbinds} = do
    (Bool
l,LCtxt
vs) <- LHsLocalBindsLR GhcTc GhcTc -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind LHsLocalBindsLR GhcTc GhcTc
lbinds
    Bool
r <- LCtxt -> Ctxt -> Ctxt
addVars LCtxt
vs (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` ([LGRHS GhcTc a] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LGRHS GhcTc a]
rhs)
    Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
  check XGRHSs{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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


boxReason :: StableReason -> p
boxReason StableReason
StableBox = p
"Nested use of box"
boxReason StableReason
StableArr = p
"The use of box in the scope of arr"
boxReason (StableRec SrcSpan
_ ) = p
"The use of box in a recursive definition"

arrReason :: StableReason -> p
arrReason StableReason
StableArr = p
"Nested use of arr"
arrReason StableReason
StableBox = p
"The use of arr in the scope of box"
arrReason (StableRec SrcSpan
_) = p
"The use of arr in a recursive definition"

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 (Stabilize StableReason
StableBox) = SDoc
"an application of box"
tickHidden (Stabilize StableReason
StableArr) = SDoc
"an application of arr"
tickHidden (Stabilize (StableRec SrcSpan
src)) = SDoc
"a nested recursive definition (at " SDoc -> SDoc -> SDoc
<> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
src SDoc -> SDoc -> SDoc
<> SDoc
")"

instance Scope (HsExpr GhcTc) where
  check :: HsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check (HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
v))
    | Just Prim
p <- GetCtxt => Var -> Maybe Prim
Var -> Maybe Prim
isPrim IdP GhcTc
Var
v =
        case Prim
p of
          Prim
Unbox -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Prim
_ -> GetCtxt => Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
printMessageCheck Severity
SevError (SDoc
"Defining an alias for " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdP GhcTc
Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is not allowed")
    | Bool
otherwise = case GetCtxt => Var -> VarScope
Var -> VarScope
getScope IdP GhcTc
Var
v of
             Hidden SDoc
reason -> GetCtxt => Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
printMessageCheck Severity
SevError SDoc
reason
             VarScope
Visible -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             VarScope
ImplUnboxed -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
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
_ 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 => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
        case Ctxt -> Maybe StableReason
stabilized GetCtxt
Ctxt
?ctxt of
          Just StableReason
reason | Bool
ch ->
            (GetCtxt => Severity -> SDoc -> TcM ()
Severity -> SDoc -> TcM ()
printMessage' Severity
SevWarning (StableReason -> SDoc
forall p. IsString p => StableReason -> p
boxReason StableReason
reason SDoc -> SDoc -> SDoc
<> SDoc
" can cause time leaks")) TcM ()
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
          Maybe StableReason
_ -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
      Prim
Arr -> do
        Bool
ch <- StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableArr (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
        -- don't bother with a warning if the scopecheck fails
        case Ctxt -> Maybe StableReason
stabilized GetCtxt
Ctxt
?ctxt of
          Just StableReason
reason | Bool
ch ->
            GetCtxt => Severity -> SDoc -> TcM ()
Severity -> SDoc -> TcM ()
printMessage' Severity
SevWarning (StableReason -> SDoc
forall p. IsString p => StableReason -> p
arrReason StableReason
reason SDoc -> SDoc -> SDoc
<> SDoc
" can cause time leaks") TcM ()
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
          Maybe StableReason
_ -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch

      Prim
Unbox -> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
      Prim
Delay ->  ((\Ctxt
c -> Ctxt
c{current :: LCtxt
current = LCtxt
forall a. Set a
Set.empty, earlier :: Either NoTickReason LCtxt
earlier = LCtxt -> Either NoTickReason LCtxt
forall a b. b -> Either a b
Right (Ctxt -> LCtxt
current GetCtxt
Ctxt
?ctxt)}) (Ctxt -> Ctxt) -> (Ctxt -> Ctxt) -> Ctxt -> Ctxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HiddenReason -> Ctxt -> Ctxt
stabilizeLater HiddenReason
DelayApp)
                  (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check  LHsExpr GhcTc
e2
      Prim
Adv -> case Ctxt -> Either NoTickReason LCtxt
earlier GetCtxt
Ctxt
?ctxt of
        Right LCtxt
er -> Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
          where mod :: Ctxt -> Ctxt
mod Ctxt
c =  Ctxt
c{earlier :: Either NoTickReason LCtxt
earlier = NoTickReason -> Either NoTickReason LCtxt
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason LCtxt)
-> NoTickReason -> Either NoTickReason LCtxt
forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
AdvApp, current :: LCtxt
current = LCtxt
er,
                           hidden :: Hidden
hidden = Ctxt -> Hidden
hidden GetCtxt
Ctxt
?ctxt Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                            (Var -> HiddenReason) -> LCtxt -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
AdvApp) (Ctxt -> LCtxt
current GetCtxt
Ctxt
?ctxt)}
        Left NoTickReason
NoDelay -> GetCtxt => Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay.")
        Left (TickHidden HiddenReason
hr) -> GetCtxt => Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) 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
".")
    Maybe (Prim, Var)
_ -> (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1)  (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2)
  check HsUnboundVar{}  = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsConLikeOut{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsRecFld{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsOverLabel{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsIPVar{} = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"implicit parameters"
  check HsOverLit{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  
#if __GLASGOW_HASKELL__ >= 808
  check (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_)
#else
  check (HsAppType _ e)
#endif
    = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  
  check (HsTick XTick GhcTc
_ Tickish (IdP GhcTc)
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e  
  check (HsSCC XSCC GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (HsWrap XWrap GhcTc
_ HsWrapper
_ HsExpr GhcTc
e) = HsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check HsExpr GhcTc
e
  check HsLit{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
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)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [LHsExpr GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
  check (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = HiddenReason -> Ctxt -> Ctxt
stabilizeLater HiddenReason
FunDef (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` MatchGroup GhcTc (LHsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = HiddenReason -> Ctxt -> Ctxt
stabilizeLater HiddenReason
FunDef (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` MatchGroup GhcTc (LHsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check (HsIf XIf GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [LHsExpr GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
  check (HsCase XCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsExpr GhcTc)
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MatchGroup GhcTc (LHsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
e2
  check (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
  check (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
  check (ExplicitTuple XExplicitTuple GhcTc
_ [LHsTupArg GhcTc]
e Boxity
_) = [LHsTupArg GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsTupArg GhcTc]
e
  check (HsLet XLet GhcTc
_ LHsLocalBindsLR GhcTc GhcTc
bs LHsExpr GhcTc
e) = do
    (Bool
l,LCtxt
vs) <- LHsLocalBindsLR GhcTc GhcTc -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind LHsLocalBindsLR GhcTc GhcTc
bs
    Bool
r <- LCtxt -> Ctxt -> Ctxt
addVars LCtxt
vs (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e)
    Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
  check (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
_) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (HsMultiIf XMultiIf GhcTc
_ [LGRHS GhcTc (LHsExpr GhcTc)]
e) = [LGRHS GhcTc (LHsExpr GhcTc)] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LGRHS GhcTc (LHsExpr GhcTc)]
e
  check (ExplicitList XExplicitList GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ [LHsExpr GhcTc]
e) = [LHsExpr GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsExpr GhcTc]
e
  check RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
f} = HsRecordBinds GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check HsRecordBinds GhcTc
f
  check RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e, rupd_flds :: forall p. HsExpr p -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcTc]
fs} = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [LHsRecUpdField GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsRecUpdField GhcTc]
fs
#if __GLASGOW_HASKELL__ >= 808
  check (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_)
#else
  check (ExprWithTySig _ e)
#endif
    = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ ArithSeqInfo GhcTc
e) = ArithSeqInfo GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check ArithSeqInfo GhcTc
e
  check HsBracket{} = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsRnBracketOut{} = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsTcBracketOut{} = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsSpliceE{} = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"Template Haskell"
  check (HsProc XProc GhcTc
_ LPat GhcTc
p LHsCmdTop GhcTc
e) = Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsCmdTop GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmdTop GhcTc
e
    where mod :: Ctxt -> Ctxt
mod Ctxt
c = LCtxt -> Ctxt -> Ctxt
addVars (Located (Pat GhcTc) -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV LPat GhcTc
Located (Pat GhcTc)
p) (StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableArr Ctxt
c)
  check (HsStatic XStatic GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (HsDo XDo GhcTc
_ HsStmtContext Name
_ Located [GuardLStmt GhcTc]
e) = (Bool, LCtxt) -> Bool
forall a b. (a, b) -> a
fst ((Bool, LCtxt) -> Bool)
-> TcM (Bool, LCtxt) -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located [GuardLStmt GhcTc] -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind Located [GuardLStmt GhcTc]
e
  check (HsCoreAnn XCoreAnn GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check (HsTickPragma XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Int, Int), (Int, Int))
_ ((SourceText, SourceText), (SourceText, SourceText))
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check XExpr {} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if __GLASGOW_HASKELL__ < 810
  check HsArrApp{} = impossible
  check HsArrForm{} = impossible
  check EWildPat{} = impossible
  check EAsPat{} = impossible
  check EViewPat{} = impossible
  check ELazyPat{} = impossible

impossible :: GetCtxt => TcM Bool
impossible = printMessageCheck SevError "This syntax should never occur after typechecking"
#endif


instance Scope (HsCmdTop GhcTc) where
  check :: HsCmdTop GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check (HsCmdTop XCmdTop GhcTc
_ LHsCmd GhcTc
e) = LHsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmd GhcTc
e
  check XCmdTop{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

instance Scope (HsCmd GhcTc) where
  check :: HsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check (HsCmdArrApp XCmdArrApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
_ Bool
_) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
  check (HsCmdDo XCmdDo GhcTc
_ Located [CmdLStmt GhcTc]
e) = (Bool, LCtxt) -> Bool
forall a b. (a, b) -> a
fst ((Bool, LCtxt) -> Bool)
-> TcM (Bool, LCtxt) -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located [CmdLStmt GhcTc] -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind Located [CmdLStmt GhcTc]
e
  check (HsCmdArrForm XCmdArrForm GhcTc
_ LHsExpr GhcTc
e1 LexicalFixity
_ Maybe Fixity
_ [LHsCmdTop GhcTc]
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [LHsCmdTop GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsCmdTop GhcTc]
e2
  check (HsCmdApp XCmdApp GhcTc
_ LHsCmd GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmd GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e2
  check (HsCmdLam XCmdLam GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = MatchGroup GhcTc (LHsCmd GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e
  check (HsCmdPar XCmdPar GhcTc
_ LHsCmd GhcTc
e) = LHsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmd GhcTc
e
  check (HsCmdCase XCmdCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsCmd GhcTc)
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MatchGroup GhcTc (LHsCmd GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e2
  check (HsCmdIf XCmdIf GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ LHsExpr GhcTc
e1 LHsCmd GhcTc
e2 LHsCmd GhcTc
e3) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmd GhcTc
e2) IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmd GhcTc
e3
  check (HsCmdLet XCmdLet GhcTc
_ LHsLocalBindsLR GhcTc GhcTc
bs LHsCmd GhcTc
e) = do
    (Bool
l,LCtxt
vs) <- LHsLocalBindsLR GhcTc GhcTc -> TcM (Bool, LCtxt)
forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, LCtxt)
checkBind LHsLocalBindsLR GhcTc GhcTc
bs
    Bool
r <- LCtxt -> Ctxt -> Ctxt
addVars LCtxt
vs (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (LHsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsCmd GhcTc
e)
    Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
  check (HsCmdWrap XCmdWrap GhcTc
_ HsWrapper
_ HsCmd GhcTc
e) = HsCmd GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check HsCmd GhcTc
e
  check XCmd{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


-- | This is used when checking function definitions. If the context
-- is not ticked, it stays the same. Otherwise, it is stabilized
-- (similar to 'box').
stabilizeLater :: HiddenReason -> Ctxt -> Ctxt
stabilizeLater :: HiddenReason -> Ctxt -> Ctxt
stabilizeLater HiddenReason
reason Ctxt
c =
  case Ctxt -> Either NoTickReason LCtxt
earlier Ctxt
c of
    Left NoTickReason
_ -> Ctxt
c
    Right LCtxt
earl ->
      Ctxt
c {earlier :: Either NoTickReason LCtxt
earlier = NoTickReason -> Either NoTickReason LCtxt
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason LCtxt)
-> NoTickReason -> Either NoTickReason LCtxt
forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
reason,
         hidden :: Hidden
hidden = Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Ctxt -> Hidden
hidden Ctxt
c) (Hidden -> Hidden) -> Hidden -> Hidden
forall a b. (a -> b) -> a -> b
$ (Var -> HiddenReason) -> LCtxt -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
reason) LCtxt
earl}


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

instance Scope (HsRecordBinds GhcTc) where
  check :: HsRecordBinds GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check HsRecFields {rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds = [LHsRecField GhcTc (LHsExpr GhcTc)]
fs} = [LHsRecField GhcTc (LHsExpr GhcTc)]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check [LHsRecField GhcTc (LHsExpr GhcTc)]
fs

instance Scope (HsRecField' a (LHsExpr GhcTc)) where
  check :: HsRecField' a (LHsExpr GhcTc) -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check HsRecField{hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcTc
a} = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
a

instance Scope (HsTupArg GhcTc) where
  check :: HsTupArg GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check (Present XPresent GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
e
  check Missing{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check XTupArg{} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  
instance Scope (HsBindLR GhcTc GhcTc) where
  check :: HsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) 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} = Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` Bag (LHsBindLR GhcTc GhcTc) -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check Bag (LHsBindLR GhcTc GhcTc)
binds
    where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes :: LCtxt
stableTypes= Ctxt -> LCtxt
stableTypes Ctxt
c LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                      [Var] -> LCtxt
forall a. Ord a => [a] -> Set a
Set.fromList ((Var -> Maybe Var) -> [Var] -> [Var]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe Var
isStableConstr (Type -> Maybe Var) -> (Var -> Type) -> Var -> Maybe Var
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 -> Located (IdP idL)
fun_id = L SrcSpan
_ IdP GhcTc
v} = Ctxt -> Ctxt
mod (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` MatchGroup GhcTc (LHsExpr GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
matches
    where mod :: Ctxt -> Ctxt
mod Ctxt
c = Ctxt
c { stableTypes :: LCtxt
stableTypes= Ctxt -> LCtxt
stableTypes Ctxt
c LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
`Set.union`
                      [Var] -> LCtxt
forall a. Ord a => [a] -> Set a
Set.fromList (Type -> [Var]
extractStableConstr (Var -> Type
varType IdP GhcTc
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} = LCtxt -> Ctxt -> Ctxt
addVars (Located (Pat GhcTc) -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV LPat GhcTc
Located (Pat GhcTc)
lhs) (Ctxt -> Ctxt)
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc (LHsExpr GhcTc) -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check GRHSs GhcTc (LHsExpr GhcTc)
rhs
  check VarBind{var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
rhs} = LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsExpr GhcTc
rhs
  check PatSynBind {} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- pattern synonyms are not supported
  check XHsBindsLR {} = Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


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


-- | 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
. ([Type], Type) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Type) -> [Type])
-> (Type -> ([Type], Type)) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Type], Type)
splitFunTys (Type -> ([Type], Type))
-> (Type -> Type) -> Type -> ([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


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

checkSCC :: ErrorMsgsRef -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM Bool
checkSCC :: ErrorMsgsRef
-> SCC (LHsBindLR GhcTc GhcTc, LCtxt)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
checkSCC ErrorMsgsRef
errm (AcyclicSCC (LHsBindLR GhcTc GhcTc
b,LCtxt
_)) = Ctxt
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Ctxt
emptyCtxt ErrorMsgsRef
errm Maybe RecDef
forall a. Maybe a
Nothing) (LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsBindLR GhcTc GhcTc
b)

checkSCC ErrorMsgsRef
errm (CyclicSCC [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs) = (([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> [LHsBindLR GhcTc GhcTc] -> IOEnv (Env TcGblEnv TcLclEnv) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check' [LHsBindLR GhcTc GhcTc]
bs'))
  where bs' :: [LHsBindLR GhcTc GhcTc]
bs' = ((LHsBindLR GhcTc GhcTc, LCtxt) -> LHsBindLR GhcTc GhcTc)
-> [(LHsBindLR GhcTc GhcTc, LCtxt)] -> [LHsBindLR GhcTc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (LHsBindLR GhcTc GhcTc, LCtxt) -> LHsBindLR GhcTc GhcTc
forall a b. (a, b) -> a
fst [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs
        vs :: LCtxt
vs = ((LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt)
-> [(LHsBindLR GhcTc GhcTc, LCtxt)] -> LCtxt
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt
forall a b. (a, b) -> b
snd [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs
        check' :: LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check' b :: LHsBindLR GhcTc GhcTc
b@(L SrcSpan
l HsBindLR GhcTc GhcTc
_) = Ctxt
-> (GetCtxt => IOEnv (Env TcGblEnv TcLclEnv) Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt (ErrorMsgsRef -> Maybe RecDef -> Ctxt
emptyCtxt ErrorMsgsRef
errm (RecDef -> Maybe RecDef
forall a. a -> Maybe a
Just (LCtxt
vs,SrcSpan
l))) (LHsBindLR GhcTc GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a.
(Scope a, GetCtxt) =>
a -> IOEnv (Env TcGblEnv TcLclEnv) Bool
check LHsBindLR GhcTc GhcTc
b)

-- | Stabilizes the given context, i.e. remove all non-stable types
-- and any tick. This is performed on checking 'box', 'arr' 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 :: LCtxt
current = LCtxt
forall a. Set a
Set.empty,
   earlier :: Either NoTickReason LCtxt
earlier = NoTickReason -> Either NoTickReason LCtxt
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason LCtxt)
-> NoTickReason -> Either NoTickReason LCtxt
forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
hr,
   hidden :: Hidden
hidden = Ctxt -> Hidden
hidden Ctxt
c Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Var -> HiddenReason) -> LCtxt -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
hr) LCtxt
ctxHid,
   stabilized :: Maybe StableReason
stabilized = StableReason -> Maybe StableReason
forall a. a -> Maybe a
Just StableReason
sr}
  where ctxHid :: LCtxt
ctxHid = (NoTickReason -> LCtxt)
-> (LCtxt -> LCtxt) -> Either NoTickReason LCtxt -> LCtxt
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LCtxt -> NoTickReason -> LCtxt
forall a b. a -> b -> a
const (LCtxt -> NoTickReason -> LCtxt) -> LCtxt -> NoTickReason -> LCtxt
forall a b. (a -> b) -> a -> b
$ Ctxt -> LCtxt
current Ctxt
c) (LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> LCtxt
current Ctxt
c)) (Ctxt -> Either NoTickReason LCtxt
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 :: Var -> VarScope
getScope Var
v =
  case GetCtxt
Ctxt
?ctxt of
    Ctxt{recDef :: Ctxt -> Maybe RecDef
recDef = Just (LCtxt
vs,SrcSpan
_), earlier :: Ctxt -> Either NoTickReason LCtxt
earlier = Either NoTickReason LCtxt
e}
      | Var
v Var -> LCtxt -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` LCtxt
vs ->
        case Either NoTickReason LCtxt
e of
          Right LCtxt
_ -> VarScope
Visible
          Left NoTickReason
NoDelay -> SDoc -> VarScope
Hidden (SDoc
"The (mutually) recursive call to " SDoc -> SDoc -> SDoc
<> Var -> 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
<> Var -> 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 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 (LCtxt -> Type -> Bool
isStable (Ctxt -> LCtxt
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> Var -> 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
<> SrcSpan -> 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
<> Type -> 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 (LCtxt -> Type -> Bool
isStable (Ctxt -> LCtxt
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> Var -> 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
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
            Just (Stabilize StableReason
StableArr) ->
              if (LCtxt -> Type -> Bool
isStable (Ctxt -> LCtxt
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> Var -> 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 inside an arrow notation and is of type " SDoc -> SDoc -> SDoc
<> Type -> 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
<> Var -> 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
DelayApp -> SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> Var -> 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 (LCtxt -> Type -> Bool
isStable (Ctxt -> LCtxt
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v)) then VarScope
Visible
              else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> Var -> 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
<> Type -> 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
              | (NoTickReason -> Bool)
-> (LCtxt -> Bool) -> Either NoTickReason LCtxt -> 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) (Var -> LCtxt -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v) (Ctxt -> Either NoTickReason LCtxt
earlier GetCtxt
Ctxt
?ctxt) ->
                if LCtxt -> Type -> Bool
isStable (Ctxt -> LCtxt
stableTypes GetCtxt
Ctxt
?ctxt) (Var -> Type
varType Var
v) then VarScope
Visible
                else SDoc -> VarScope
Hidden (SDoc
"Variable " SDoc -> SDoc -> SDoc
<> Var -> 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
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> SDoc
", which is not stable.")
              | Var -> LCtxt -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v (Ctxt -> LCtxt
current GetCtxt
Ctxt
?ctxt) -> VarScope
Visible
              | Type -> Bool
isTemporal (Var -> Type
varType Var
v) Bool -> Bool -> Bool
&& Either NoTickReason LCtxt -> Bool
forall a b. Either a b -> Bool
isRight (Ctxt -> Either NoTickReason LCtxt
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 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
"box", Prim
Box),
   (FastString
"arr", Prim
Arr),
   (FastString
"unbox", Prim
Unbox)]


-- | Checks whether a given variable is in fact a Rattus primitive.
isPrim :: GetCtxt => Var -> Maybe Prim
isPrim :: 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 Rattus primitive.
isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim,Var)
isPrimExpr :: LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr (L SrcSpan
_ 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' :: HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' (HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
v)) = (Prim -> (Prim, Var)) -> Maybe Prim -> Maybe (Prim, Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,IdP GhcTc
Var
v) (GetCtxt => Var -> Maybe Prim
Var -> Maybe Prim
isPrim IdP GhcTc
Var
v)
  
#if __GLASGOW_HASKELL__ >= 808
  isPrimExpr' (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_)
#else
  isPrimExpr' (HsAppType _ e)
#endif
    = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  isPrimExpr' (HsTick XTick GhcTc
_ Tickish (IdP GhcTc)
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  isPrimExpr' (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e  
  isPrimExpr' (HsSCC XSCC GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  isPrimExpr' (HsWrap XWrap GhcTc
_ HsWrapper
_ HsExpr GhcTc
e) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e
  isPrimExpr' (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  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 -> TcM a

instance NotSupported Bool where
  notSupported :: SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
notSupported SDoc
doc = GetCtxt => Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
printMessageCheck Severity
SevError (SDoc
"Rattus does not support " SDoc -> SDoc -> SDoc
<> SDoc
doc)

instance NotSupported (Bool,Set Var) where
  notSupported :: SDoc -> TcM (Bool, LCtxt)
notSupported SDoc
doc = (,LCtxt
forall a. Set a
Set.empty) (Bool -> (Bool, LCtxt))
-> IOEnv (Env TcGblEnv TcLclEnv) Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
doc


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

-- | Print a message with the current location.
printMessage' :: GetCtxt => Severity -> SDoc ->  TcM ()
printMessage' :: Severity -> SDoc -> TcM ()
printMessage' Severity
sev SDoc
doc =
  IO () -> TcM ()
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 -> TcM Bool
printMessageCheck :: Severity -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Bool
printMessageCheck Severity
sev SDoc
doc = GetCtxt => Severity -> SDoc -> TcM ()
Severity -> SDoc -> TcM ()
printMessage' Severity
sev SDoc
doc TcM ()
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  case Severity
sev of
    Severity
SevError -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Severity
_ -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True