{-# 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 ((<>))

#if __GLASGOW_HASKELL__ >= 900
import GHC.Plugins
import GHC.Tc.Types
import GHC.Data.Bag
import GHC.Tc.Types.Evidence
#else
import GhcPlugins
import TcRnTypes
import TcEvidence
import Bag
#endif

#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 Data.List.NonEmpty (NonEmpty(..),(<|),nonEmpty)
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 (NonEmpty LCtxt)
earlier :: Either NoTickReason (NonEmpty LCtxt),
    -- | Variables that have fallen out of scope. The map contains the
    -- reason why they have fallen out of scope.
    Ctxt -> Hidden
hidden :: Hidden,
    -- -- | Same as 'hidden' but for recursive variables.
    -- hiddenRec :: Hidden,
    -- | The current location information.
    Ctxt -> SrcSpan
srcLoc :: SrcSpan,
    -- | If we are in the body of a recursively defined function, this
    -- field contains the variables that are defined recursively
    -- (could be more than one due to mutual recursion or because of a
    -- recursive pattern definition) and the location of the recursive
    -- definition.
    Ctxt -> Maybe RecDef
recDef :: Maybe RecDef,
    -- | Type variables with a 'Stable' constraint attached to them.
    Ctxt -> 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 (NonEmpty 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 (NonEmpty LCtxt)
earlier = NoTickReason -> Either NoTickReason (NonEmpty 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 = SrcSpan
noLocationInfo,
         recDef :: Maybe RecDef
recDef = Maybe RecDef
mvar,
         primAlias :: Map Var Prim
primAlias = Map Var Prim
forall k a. Map k a
Map.empty,
         stableTypes :: 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
  [(Bool, [ErrorMsg])]
result <- (SCC (LHsBindLR GhcTc GhcTc, LCtxt)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg]))
-> [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Bool, [ErrorMsg])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, LCtxt)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
checkSCC' (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (LHsBindLR GhcTc GhcTc, LCtxt)]
bindDep
  let (Bool
res,[ErrorMsg]
msgs) = ((Bool, [ErrorMsg]) -> (Bool, [ErrorMsg]) -> (Bool, [ErrorMsg]))
-> (Bool, [ErrorMsg]) -> [(Bool, [ErrorMsg])] -> (Bool, [ErrorMsg])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Bool
b,[ErrorMsg]
l) (Bool
b',[ErrorMsg]
l') -> (Bool
b Bool -> Bool -> Bool
&& Bool
b', [ErrorMsg]
l [ErrorMsg] -> [ErrorMsg] -> [ErrorMsg]
forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
l')) (Bool
True,[]) [(Bool, [ErrorMsg])]
result
  [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs
  if Bool
res then () -> TcM ()
forall (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 -> TcM Bool
check (L SrcSpan
l a
x) =  (\Ctxt
c -> Ctxt
c {srcLoc :: SrcSpan
srcLoc = SrcSpan
l}) (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` a -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check a
x


instance Scope (LHsBinds GhcTc) where
  check :: Bag (LHsBindLR GhcTc GhcTc) -> TcM Bool
check Bag (LHsBindLR GhcTc GhcTc)
bs = ([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool] -> TcM 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 -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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] -> TcM Bool
check [a]
ls = ([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool] -> TcM 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 -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [a]
ls)


instance Scope a => Scope (Match GhcTc a) where
  check :: Match GhcTc a -> TcM 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} = LCtxt -> Ctxt -> Ctxt
addVars ([Located (Pat GhcTc)] -> LCtxt
forall a. HasBV a => a -> LCtxt
getBV [LPat GhcTc]
[Located (Pat GhcTc)]
ps) (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc a -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check GRHSs GhcTc a
rhs
#if __GLASGOW_HASKELL__ < 900
  check XMatch{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif

  
instance Scope a => Scope (MatchGroup GhcTc a) where
  check :: MatchGroup GhcTc a -> TcM 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] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check Located [LMatch GhcTc a]
alts
#if __GLASGOW_HASKELL__ < 900
  check XMatchGroup {} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif

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)) -> TcM Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check a
b
#if __GLASGOW_HASKELL__ >= 900
  checkBind (BindStmt _ p b) = do
#else
  checkBind (BindStmt XBindStmt GhcTc GhcTc a
_ LPat GhcTc
p a
b SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_) = do
#endif
    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 => TcM Bool) -> TcM Bool
forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c' (a -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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)) -> TcM Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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"
#if __GLASGOW_HASKELL__ < 900
  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)
#endif

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 -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt`  (a -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check a
b)
    Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r')
#if __GLASGOW_HASKELL__ < 900
  check XGRHS{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif

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

checkPatBind :: GetCtxt => LHsBindLR GhcTc GhcTc -> TcM Bool
checkPatBind :: LHsBindLR GhcTc GhcTc -> TcM Bool
checkPatBind (L SrcSpan
l HsBindLR GhcTc GhcTc
b) = (\Ctxt
c -> Ctxt
c {srcLoc :: SrcSpan
srcLoc = SrcSpan
l}) (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GetCtxt => HsBindLR GhcTc GhcTc -> TcM Bool
HsBindLR GhcTc GhcTc -> TcM Bool
checkPatBind' HsBindLR GhcTc GhcTc
b

checkPatBind' :: GetCtxt => HsBindLR GhcTc GhcTc -> TcM Bool
checkPatBind' :: HsBindLR GhcTc GhcTc -> TcM Bool
checkPatBind' PatBind{} = do
  GetCtxt => Severity -> SDoc -> TcM ()
Severity -> SDoc -> TcM ()
printMessage' Severity
SevError (SDoc
"(Mutual) recursive pattern binding definitions are not supported in Rattus")
  Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         
checkPatBind' AbsBinds {abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = Bag (LHsBindLR GhcTc GhcTc)
binds} = ([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool] -> TcM Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((LHsBindLR GhcTc GhcTc -> TcM 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 GetCtxt => LHsBindLR GhcTc GhcTc -> TcM Bool
LHsBindLR GhcTc GhcTc -> TcM Bool
checkPatBind (Bag (LHsBindLR GhcTc GhcTc) -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList Bag (LHsBindLR GhcTc GhcTc)
binds))
checkPatBind' HsBindLR GhcTc GhcTc
_ = Bool -> TcM 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] -> TcM 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 -> TcM 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 -> TcM 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 -> TcM Bool
check' b :: LHsBindLR GhcTc GhcTc
b@(L SrcSpan
l HsBindLR GhcTc GhcTc
_) = SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GetCtxt => LHsBindLR GhcTc GhcTc -> TcM Bool
LHsBindLR GhcTc GhcTc -> TcM Bool
checkRec LHsBindLR GhcTc GhcTc
b
          fc :: SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l Ctxt
c = let
            ctxHid :: LCtxt
ctxHid = (NoTickReason -> LCtxt)
-> (NonEmpty LCtxt -> LCtxt)
-> Either NoTickReason (NonEmpty 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) (LCtxt -> LCtxt)
-> (NonEmpty LCtxt -> LCtxt) -> NonEmpty LCtxt -> LCtxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty LCtxt -> LCtxt
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions) (Ctxt -> Either NoTickReason (NonEmpty LCtxt)
earlier Ctxt
c)
            in Ctxt
c {current :: LCtxt
current = LCtxt
forall a. Set a
Set.empty,
                  earlier :: Either NoTickReason (NonEmpty LCtxt)
earlier = NoTickReason -> Either NoTickReason (NonEmpty 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)) -> TcM Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsBindLR GhcTc GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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)) -> TcM Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsBindLR GhcTc GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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)
#if __GLASGOW_HASKELL__ < 900
  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)
#endif
  
instance Scope a => Scope (GRHSs GhcTc a) where
  check :: GRHSs GhcTc a -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` ([LGRHS GhcTc a] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LGRHS GhcTc a]
rhs)
    Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
#if __GLASGOW_HASKELL__ < 900
  check XGRHSs{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif
  
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 -> TcM 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 -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Prim
_ -> GetCtxt => Severity -> SDoc -> TcM Bool
Severity -> SDoc -> TcM 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 -> TcM Bool
Severity -> SDoc -> TcM Bool
printMessageCheck Severity
SevError SDoc
reason
             VarScope
Visible -> Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             VarScope
ImplUnboxed -> Bool -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 () -> TcM Bool -> TcM Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
          Maybe StableReason
_ -> Bool -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 () -> TcM Bool -> TcM Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
          Maybe StableReason
_ -> Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch

      Prim
Unbox -> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
      Prim
Delay ->  ((\Ctxt
c -> Ctxt
c{current :: LCtxt
current = LCtxt
forall a. Set a
Set.empty,
                          earlier :: Either NoTickReason (NonEmpty LCtxt)
earlier = case Ctxt -> Either NoTickReason (NonEmpty LCtxt)
earlier Ctxt
c of
                                      Left NoTickReason
_ -> NonEmpty LCtxt -> Either NoTickReason (NonEmpty LCtxt)
forall a b. b -> Either a b
Right (Ctxt -> LCtxt
current Ctxt
c LCtxt -> [LCtxt] -> NonEmpty LCtxt
forall a. a -> [a] -> NonEmpty a
:| [])
                                      Right NonEmpty LCtxt
cs -> NonEmpty LCtxt -> Either NoTickReason (NonEmpty LCtxt)
forall a b. b -> Either a b
Right (Ctxt -> LCtxt
current Ctxt
c LCtxt -> NonEmpty LCtxt -> NonEmpty LCtxt
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty LCtxt
cs)}))
                  (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check  LHsExpr GhcTc
e2
      Prim
Adv -> case Ctxt -> Either NoTickReason (NonEmpty LCtxt)
earlier GetCtxt
Ctxt
?ctxt of
        Right (LCtxt
er :| [LCtxt]
ers) -> Ctxt -> Ctxt
mod (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
          where mod :: Ctxt -> Ctxt
mod Ctxt
c =  Ctxt
c{earlier :: Either NoTickReason (NonEmpty LCtxt)
earlier = case [LCtxt] -> Maybe (NonEmpty LCtxt)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [LCtxt]
ers of
                                       Maybe (NonEmpty LCtxt)
Nothing -> NoTickReason -> Either NoTickReason (NonEmpty LCtxt)
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason (NonEmpty LCtxt))
-> NoTickReason -> Either NoTickReason (NonEmpty LCtxt)
forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
AdvApp
                                       Just NonEmpty LCtxt
ers' -> NonEmpty LCtxt -> Either NoTickReason (NonEmpty LCtxt)
forall a b. b -> Either a b
Right NonEmpty LCtxt
ers',
                           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 -> TcM Bool
Severity -> SDoc -> TcM Bool
printMessageCheck Severity
SevError (SDoc
"adv may only be used in the scope of a delay.")
        Left (TickHidden HiddenReason
hr) -> GetCtxt => Severity -> SDoc -> TcM Bool
Severity -> SDoc -> TcM 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) -> TcM Bool -> TcM Bool -> TcM Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1)  (LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2)
  check HsUnboundVar{}  = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsConLikeOut{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsRecFld{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsOverLabel{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsIPVar{} = SDoc -> TcM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"implicit parameters"
  check HsOverLit{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True  
  check (HsTick XTick GhcTc
_ Tickish (IdP GhcTc)
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e  
  check (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check HsLit{} = Bool -> TcM 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] -> TcM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsExpr GhcTc -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
  check (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = MatchGroup GhcTc (LHsExpr GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = MatchGroup GhcTc (LHsExpr GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check (HsCase XCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsExpr GhcTc)
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MatchGroup GhcTc (LHsExpr GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
e2
  check (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
  check (SectionR XSectionR GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
  check (ExplicitTuple XExplicitTuple GhcTc
_ [LHsTupArg GhcTc]
e Boxity
_) = [LHsTupArg GhcTc] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e)
    Bool -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsMultiIf XMultiIf GhcTc
_ [LGRHS GhcTc (LHsExpr GhcTc)]
e) = [LGRHS GhcTc (LHsExpr GhcTc)] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LGRHS GhcTc (LHsExpr GhcTc)]
e
  check (ExplicitList XExplicitList GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ [LHsExpr GhcTc]
e) = [LHsExpr GhcTc] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsExpr GhcTc]
e
  check RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
f} = HsRecordBinds GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [LHsRecUpdField GhcTc] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsRecUpdField GhcTc]
fs
  check (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ ArithSeqInfo GhcTc
e) = ArithSeqInfo GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check ArithSeqInfo GhcTc
e
  check HsBracket{} = SDoc -> TcM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsRnBracketOut{} = SDoc -> TcM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsTcBracketOut{} = SDoc -> TcM Bool
forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsSpliceE{} = SDoc -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` LHsCmdTop GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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) -> TcM 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 (XExpr XXExpr GhcTc
e) = NoExtCon -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check NoExtCon
XXExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 808
  check (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
#else
  check (HsAppType _ e)  = check e
  check (ExprWithTySig _ e) = check e
#endif

#if __GLASGOW_HASKELL__ >= 900
  check (HsPragE _ _ e) = check e
  check (HsIf _ e1 e2 e3) = and <$> mapM check [e1,e2,e3]
#else
  check (HsSCC XSCC GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsCoreAnn XCoreAnn GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsTickPragma XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Int, Int), (Int, Int))
_ ((SourceText, SourceText), (SourceText, SourceText))
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsWrap XWrap GhcTc
_ HsWrapper
_ HsExpr GhcTc
e) = HsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check HsExpr GhcTc
e
  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] -> TcM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LHsExpr GhcTc -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
#endif
#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

#if __GLASGOW_HASKELL__ >= 900
instance Scope XXExprGhcTc where
  check (WrapExpr (HsWrap _ e)) = check e
  check (ExpansionExpr (HsExpanded _ e)) = check e
#elif __GLASGOW_HASKELL__ >= 810
instance Scope NoExtCon where
  check :: NoExtCon -> TcM Bool
check NoExtCon
_ = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#else
instance Scope NoExt where
  check _ = return True
#endif

instance Scope (HsCmdTop GhcTc) where
  check :: HsCmdTop GhcTc -> TcM Bool
check (HsCmdTop XCmdTop GhcTc
_ LHsCmd GhcTc
e) = LHsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e
#if __GLASGOW_HASKELL__ < 900
  check XCmdTop{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif
  
instance Scope (HsCmd GhcTc) where
  check :: HsCmd GhcTc -> TcM Bool
check (HsCmdArrApp XCmdArrApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 HsArrAppType
_ Bool
_) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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) -> TcM 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)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [LHsCmdTop GhcTc] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsCmdTop GhcTc]
e2
  check (HsCmdApp XCmdApp GhcTc
_ LHsCmd GhcTc
e1 LHsExpr GhcTc
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
  check (HsCmdLam XCmdLam GhcTc
_ MatchGroup GhcTc (LHsCmd GhcTc)
e) = MatchGroup GhcTc (LHsCmd GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e
  check (HsCmdPar XCmdPar GhcTc
_ LHsCmd GhcTc
e) = LHsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e
  check (HsCmdCase XCmdCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsCmd GhcTc)
e2) = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MatchGroup GhcTc (LHsCmd GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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)
-> TcM 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)
-> TcM Bool -> IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e2) IOEnv (Env TcGblEnv TcLclEnv) (Bool -> Bool)
-> TcM Bool -> TcM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (LHsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e)
    Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
#if __GLASGOW_HASKELL__ >= 900
  check (XCmd (HsWrap _ e)) = check e
  check (HsCmdLamCase _ e) = check e
#else
  check (HsCmdWrap XCmdWrap GhcTc
_ HsWrapper
_ HsCmd GhcTc
e) = HsCmd GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check HsCmd GhcTc
e
  check XCmd{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif


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

instance Scope (HsRecordBinds GhcTc) where
  check :: HsRecordBinds GhcTc -> TcM 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)] -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsRecField GhcTc (LHsExpr GhcTc)]
fs

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

instance Scope (HsTupArg GhcTc) where
  check :: HsTupArg GhcTc -> TcM Bool
check (Present XPresent GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check Missing{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if __GLASGOW_HASKELL__ < 900
  check XTupArg{} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif

instance Scope (HsBindLR GhcTc GhcTc) where
  check :: HsBindLR GhcTc GhcTc -> TcM 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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` Bag (LHsBindLR GhcTc GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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,
#if __GLASGOW_HASKELL__ >= 900
                fun_ext = wrapper} =
#else
                fun_co_fn :: forall idL idR. HsBindLR idL idR -> HsWrapper
fun_co_fn = HsWrapper
wrapper} =
#endif
      Ctxt -> Ctxt
mod (Ctxt -> Ctxt) -> (GetCtxt => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` MatchGroup GhcTc (LHsExpr GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 (HsWrapper -> [Var]
stableConstrFromWrapper HsWrapper
wrapper)  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 => TcM Bool) -> GetCtxt => TcM Bool
forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GRHSs GhcTc (LHsExpr GhcTc) -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
rhs
  check PatSynBind {} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- pattern synonyms are not supported
#if __GLASGOW_HASKELL__ < 900
  check XHsBindsLR {} = Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#endif


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


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


-- | Given a type @(C1, ... Cn) => t@, this function returns the list
-- of type variables @[a1,...,am]@ for which there is a constraint
-- @Stable ai@ among @C1, ... Cn@.
extractStableConstr :: Type -> [TyVar]
#if __GLASGOW_HASKELL__ >= 900
extractStableConstr  = mapMaybe isStableConstr . map irrelevantMult . fst . splitFunTys . snd . splitForAllTys
#else
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
#endif


getSCCLoc :: SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc :: SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> SrcSpan
getSCCLoc (AcyclicSCC (L SrcSpan
l HsBindLR GhcTc GhcTc
_ ,LCtxt
_)) = SrcSpan
l
getSCCLoc (CyclicSCC ((L SrcSpan
l HsBindLR GhcTc GhcTc
_,LCtxt
_ ) : [(LHsBindLR GhcTc GhcTc, LCtxt)]
_)) = SrcSpan
l
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, LCtxt)
_ = SrcSpan
noLocationInfo


checkSCC' ::  Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg])
checkSCC' :: Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, LCtxt)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
checkSCC' Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc = do
  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 <- ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> TcM Bool
checkSCC ErrorMsgsRef
err SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc
  [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)
  let anns :: Set InternalAnn
anns = Module
-> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> Set InternalAnn
getInternalAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc
  if InternalAnn
ExpectWarning InternalAnn -> Set InternalAnn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns 
    then if InternalAnn
ExpectError InternalAnn -> Set InternalAnn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
         then (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc, SDoc
"Annotation to expect both warning and error is not allowed.")])
         else if (ErrorMsg -> Bool) -> [ErrorMsg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
True; Severity
_ -> Bool
False) [ErrorMsg]
msgs
              then (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, (ErrorMsg -> Bool) -> [ErrorMsg] -> [ErrorMsg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
False; Severity
_ -> Bool
True) [ErrorMsg]
msgs)
              else (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc, SDoc
"Warning was expected, but typechecking produced no warning.")])
    else if InternalAnn
ExpectError InternalAnn -> Set InternalAnn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
         then if Bool
res
              then (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc, SDoc
"Error was expected, but typechecking produced no error.")])
              else (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[])
         else (Bool, [ErrorMsg])
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, [ErrorMsg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, [ErrorMsg]
msgs)


getInternalAnn :: Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> Set InternalAnn
getInternalAnn :: Module
-> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, LCtxt) -> Set InternalAnn
getInternalAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc =
  case SCC (LHsBindLR GhcTc GhcTc, LCtxt)
scc of
    (AcyclicSCC (LHsBindLR GhcTc GhcTc
_,LCtxt
vs)) -> Set (Set InternalAnn) -> Set InternalAnn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set InternalAnn) -> Set InternalAnn)
-> Set (Set InternalAnn) -> Set InternalAnn
forall a b. (a -> b) -> a -> b
$ (Var -> Set InternalAnn) -> LCtxt -> Set (Set InternalAnn)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set InternalAnn
checkVar LCtxt
vs
    (CyclicSCC [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs) -> [Set InternalAnn] -> Set InternalAnn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set InternalAnn] -> Set InternalAnn)
-> [Set InternalAnn] -> Set InternalAnn
forall a b. (a -> b) -> a -> b
$ ((LHsBindLR GhcTc GhcTc, LCtxt) -> Set InternalAnn)
-> [(LHsBindLR GhcTc GhcTc, LCtxt)] -> [Set InternalAnn]
forall a b. (a -> b) -> [a] -> [b]
map (Set (Set InternalAnn) -> Set InternalAnn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set InternalAnn) -> Set InternalAnn)
-> ((LHsBindLR GhcTc GhcTc, LCtxt) -> Set (Set InternalAnn))
-> (LHsBindLR GhcTc GhcTc, LCtxt)
-> Set InternalAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> Set InternalAnn) -> LCtxt -> Set (Set InternalAnn)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Var -> Set InternalAnn
checkVar (LCtxt -> Set (Set InternalAnn))
-> ((LHsBindLR GhcTc GhcTc, LCtxt) -> LCtxt)
-> (LHsBindLR GhcTc GhcTc, LCtxt)
-> Set (Set InternalAnn)
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 -> Set InternalAnn
        checkVar :: Var -> Set InternalAnn
checkVar Var
v =
          let anns :: [InternalAnn]
anns = ([Word8] -> InternalAnn)
-> AnnEnv -> CoreAnnTarget -> [InternalAnn]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> InternalAnn
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (Name -> CoreAnnTarget
forall name. name -> AnnTarget name
NamedTarget Name
name) :: [InternalAnn]
              annsMod :: [InternalAnn]
annsMod = ([Word8] -> InternalAnn)
-> AnnEnv -> CoreAnnTarget -> [InternalAnn]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> InternalAnn
forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (Module -> CoreAnnTarget
forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [InternalAnn]
              name :: Name
              name :: Name
name = Var -> Name
varName Var
v
          in [InternalAnn] -> Set InternalAnn
forall a. Ord a => [a] -> Set a
Set.fromList [InternalAnn]
anns Set InternalAnn -> Set InternalAnn -> Set InternalAnn
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [InternalAnn] -> Set InternalAnn
forall a. Ord a => [a] -> Set a
Set.fromList [InternalAnn]
annsMod



-- | 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) -> TcM Bool
checkSCC ErrorMsgsRef
errm (AcyclicSCC (LHsBindLR GhcTc GhcTc
b,LCtxt
_)) = Ctxt -> (GetCtxt => TcM Bool) -> TcM 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 -> TcM Bool
forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsBindLR GhcTc GhcTc
b)

checkSCC ErrorMsgsRef
errm (CyclicSCC [(LHsBindLR GhcTc GhcTc, LCtxt)]
bs) = (([Bool] -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) [Bool] -> TcM 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 -> TcM 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 -> TcM 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 -> TcM Bool
check' b :: LHsBindLR GhcTc GhcTc
b@(L SrcSpan
l HsBindLR GhcTc GhcTc
_) = Ctxt -> (GetCtxt => TcM Bool) -> TcM 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))) (GetCtxt => LHsBindLR GhcTc GhcTc -> TcM Bool
LHsBindLR GhcTc GhcTc -> TcM Bool
checkRec 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 (NonEmpty LCtxt)
earlier = NoTickReason -> Either NoTickReason (NonEmpty LCtxt)
forall a b. a -> Either a b
Left (NoTickReason -> Either NoTickReason (NonEmpty LCtxt))
-> NoTickReason -> Either NoTickReason (NonEmpty 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)
-> (NonEmpty LCtxt -> LCtxt)
-> Either NoTickReason (NonEmpty 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) -> LCtxt -> NonEmpty LCtxt -> LCtxt
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LCtxt -> LCtxt -> LCtxt
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> LCtxt
current Ctxt
c)) (Ctxt -> Either NoTickReason (NonEmpty 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 (NonEmpty LCtxt)
earlier = Either NoTickReason (NonEmpty LCtxt)
e}
      | Var
v Var -> LCtxt -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` LCtxt
vs ->
        case Either NoTickReason (NonEmpty LCtxt)
e of
          Right NonEmpty 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)
-> (NonEmpty LCtxt -> Bool)
-> Either NoTickReason (NonEmpty 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) ((LCtxt -> Bool) -> NonEmpty LCtxt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Var -> LCtxt -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v)) (Ctxt -> Either NoTickReason (NonEmpty 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 (NonEmpty LCtxt) -> Bool
forall a b. Either a b -> Bool
isRight (Ctxt -> Either NoTickReason (NonEmpty 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)
_) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#else
  isPrimExpr' (HsAppType _ e)   = isPrimExpr e
#endif

#if __GLASGOW_HASKELL__ < 900
  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' (HsCoreAnn XCoreAnn GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
  isPrimExpr' (HsTickPragma XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Int, Int), (Int, Int))
_ ((SourceText, SourceText), (SourceText, SourceText))
_ 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
#else
  isPrimExpr' (XExpr (WrapExpr (HsWrap _ e))) = isPrimExpr' e
  isPrimExpr' (XExpr (ExpansionExpr (HsExpanded _ e))) = isPrimExpr' e
  isPrimExpr' (HsPragE _ _ e) = isPrimExpr e
#endif
  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' (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 -> TcM Bool
notSupported SDoc
doc = GetCtxt => Severity -> SDoc -> TcM Bool
Severity -> SDoc -> TcM 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)) -> TcM Bool -> TcM (Bool, LCtxt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SDoc -> TcM 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 -> TcM Bool
printMessageCheck Severity
sev SDoc
doc = GetCtxt => Severity -> SDoc -> TcM ()
Severity -> SDoc -> TcM ()
printMessage' Severity
sev SDoc
doc TcM () -> TcM Bool -> TcM Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  case Severity
sev of
    Severity
SevError -> Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Severity
_ -> Bool -> TcM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True