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



-- | This module implements the source plugin that checks the variable
-- scope of of 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__ >= 902
import GHC.Parser.Annotation
#endif

#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 Data.Data hiding (tyConName)

import Control.Monad

type ErrorMsg = (Severity,SrcSpan,SDoc)
type ErrorMsgsRef = IORef [ErrorMsg]

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



-- | The starting context for checking a top-level definition. For
-- non-recursive definitions, the argument is @Nothing@. Otherwise, it
-- contains the recursively defined variables along with the location
-- of the recursive definition.
emptyCtxt :: ErrorMsgsRef -> Maybe (Set Var,SrcSpan) -> Bool -> Ctxt
emptyCtxt :: ErrorMsgsRef -> Maybe RecDef -> Bool -> Ctxt
emptyCtxt ErrorMsgsRef
em Maybe RecDef
mvar Bool
allowRec =
  Ctxt { errorMsgs :: ErrorMsgsRef
errorMsgs = ErrorMsgsRef
em,
         current :: Set Var
current =  forall a. Set a
Set.empty,
         earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left NoTickReason
NoDelay,
         hidden :: Hidden
hidden = forall k a. Map k a
Map.empty,
         srcLoc :: SrcSpan
srcLoc = SrcSpan
noLocationInfo,
         recDef :: Maybe RecDef
recDef = Maybe RecDef
mvar,
         primAlias :: Map Var Prim
primAlias = forall k a. Map k a
Map.empty,
         stableTypes :: Set Var
stableTypes = forall a. Set a
Set.empty,
         stabilized :: Maybe StableReason
stabilized = case Maybe RecDef
mvar of
           Just (Set Var
_,SrcSpan
loc) ->  forall a. a -> Maybe a
Just (SrcSpan -> StableReason
StableRec SrcSpan
loc)
           Maybe RecDef
_  ->  forall a. Maybe a
Nothing,
         allowRecursion :: Bool
allowRecursion = Bool
allowRec}

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

-- | The recursively defined variables + the position where the
-- recursive definition starts
type RecDef = (Set Var, SrcSpan)




data StableReason = StableRec SrcSpan | StableBox | StableArr deriving Int -> StableReason -> ShowS
[StableReason] -> ShowS
StableReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StableReason] -> ShowS
$cshowList :: [StableReason] -> ShowS
show :: StableReason -> String
$cshow :: StableReason -> String
showsPrec :: Int -> StableReason -> ShowS
$cshowsPrec :: Int -> StableReason -> ShowS
Show

-- | Indicates, why a variable has fallen out of scope.
data HiddenReason = Stabilize StableReason | FunDef | DelayApp | AdvApp deriving Int -> HiddenReason -> ShowS
[HiddenReason] -> ShowS
HiddenReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HiddenReason] -> ShowS
$cshowList :: [HiddenReason] -> ShowS
show :: HiddenReason -> String
$cshow :: HiddenReason -> String
showsPrec :: Int -> HiddenReason -> ShowS
$cshowsPrec :: Int -> HiddenReason -> ShowS
Show

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

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

-- | The 4 primitive Rattus operations plus 'arr'.
data Prim = Delay | Adv | Box | Unbox | Arr deriving Int -> Prim -> ShowS
[Prim] -> ShowS
Prim -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prim] -> ShowS
$cshowList :: [Prim] -> ShowS
show :: Prim -> String
$cshow :: Prim -> String
showsPrec :: Int -> Prim -> ShowS
$cshowsPrec :: Int -> Prim -> ShowS
Show

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


-- | 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 :: forall a. Ctxt -> (GetCtxt => a) -> a
setCtxt Ctxt
c GetCtxt => a
a = let ?ctxt = Ctxt
c in GetCtxt => a
a


-- | modify the current context.
modifyCtxt :: (Ctxt -> Ctxt) -> (GetCtxt => a) -> (GetCtxt => a)
modifyCtxt :: forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
modifyCtxt Ctxt -> Ctxt
f GetCtxt => a
a =
  let newc :: Ctxt
newc = Ctxt -> Ctxt
f GetCtxt
?ctxt in
  let ?ctxt = Ctxt
newc in GetCtxt => a
a



#if __GLASGOW_HASKELL__ >= 902
getLocAnn' :: SrcSpanAnn' b -> SrcSpan
getLocAnn' :: forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' = forall b. SrcSpanAnn' b -> SrcSpan
locA


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

#else
getLocAnn' :: SrcSpan -> SrcSpan
getLocAnn' s = s


updateLoc :: SrcSpan -> (GetCtxt => a) -> (GetCtxt => a)
updateLoc src = modifyCtxt (\c -> c {srcLoc = src})
#endif



-- | Check all definitions in the given module. If Scope errors are
-- found, the current execution is halted with 'exitFailure'.
checkAll :: TcGblEnv -> TcM ()
checkAll :: TcGblEnv -> TcM ()
checkAll TcGblEnv
env = do
  let dep :: [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dep = Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency (TcGblEnv -> Bag (LHsBindLR GhcTc GhcTc)
tcg_binds TcGblEnv
env)
  let bindDep :: [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep = forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Bool
filterBinds (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dep
  [(Bool, [ErrorMsg])]
result <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> TcM (Bool, [ErrorMsg])
checkSCC' (TcGblEnv -> Module
tcg_mod TcGblEnv
env) (TcGblEnv -> AnnEnv
tcg_ann_env TcGblEnv
env)) [SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bindDep
  let (Bool
res,[ErrorMsg]
msgs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Bool
b,[ErrorMsg]
l) (Bool
b',[ErrorMsg]
l') -> (Bool
b Bool -> Bool -> Bool
&& Bool
b', [ErrorMsg]
l forall a. [a] -> [a] -> [a]
++ [ErrorMsg]
l')) (Bool
True,[]) [(Bool, [ErrorMsg])]
result
  [ErrorMsg] -> TcM ()
printAccErrMsgs [ErrorMsg]
msgs
  if Bool
res then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure


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


-- | This function checks whether a given top-level definition (either
-- a single non-recursive definition or a group of mutual recursive
-- definitions) is marked as 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, Set Var) -> Bool
filterBinds Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc =
  case SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc of
    (AcyclicSCC (LHsBindLR GhcTc GhcTc
_,Set Var
vs)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar Set Var
vs
    (CyclicSCC [(LHsBindLR GhcTc GhcTc, Set Var)]
bs) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
checkVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(LHsBindLR GhcTc GhcTc, Set Var)]
bs
  where checkVar :: Var -> Bool
        checkVar :: Var -> Bool
checkVar Var
v =
          let anns :: [Rattus]
anns = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. name -> AnnTarget name
NamedTarget Name
name) :: [Rattus]
              annsMod :: [Rattus]
annsMod = forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns forall a. Data a => [Word8] -> a
deserializeWithData AnnEnv
anEnv (forall name. Module -> AnnTarget name
ModuleTarget Module
mod) :: [Rattus]
              name :: Name
              name :: Name
name = Var -> Name
varName Var
v
          in Rattus
Rattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rattus]
anns Bool -> Bool -> Bool
|| (Bool -> Bool
not (Rattus
NotRattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rattus]
anns)  Bool -> Bool -> Bool
&& Rattus
Rattus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rattus]
annsMod)



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


#if __GLASGOW_HASKELL__ >= 902
instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where
  check :: GetCtxt => GenLocated (SrcSpanAnn' b) a -> TcM Bool
check (L SrcSpanAnn' b
l a
x) =  forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l forall a b. (a -> b) -> a -> b
$ forall a. (Scope a, GetCtxt) => a -> TcM Bool
check a
x
#endif

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

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


instance Scope (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
  check :: GetCtxt =>
Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs} = Set Var -> Ctxt -> Ctxt
addVars (forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
ps) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> TcM Bool
check GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rhs
#if __GLASGOW_HASKELL__ < 900
  check XMatch{} = return True
#endif

instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
  check :: GetCtxt =>
Match GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> 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 (GenLocated SrcSpanAnnA (HsCmd GhcTc))
rhs} = Set Var -> Ctxt -> Ctxt
addVars (forall a. HasBV a => a -> Set Var
getBV [LPat GhcTc]
ps) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> TcM Bool
check GRHSs GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))
rhs
#if __GLASGOW_HASKELL__ < 900
  check XMatch{} = return True
#endif


instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where
  check :: GetCtxt =>
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
alts} = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
alts
#if __GLASGOW_HASKELL__ < 900
  check XMatchGroup {} = return True
#endif


instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where
  check :: GetCtxt =>
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc)) -> TcM Bool
check MG {mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
alts} = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsCmd GhcTc))]
alts
#if __GLASGOW_HASKELL__ < 900
  check XMatchGroup {} = return True
#endif


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

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

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

#if __GLASGOW_HASKELL__ >= 902
instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where
  checkBind :: GetCtxt => GenLocated (SrcSpanAnn' b) a -> TcM (Bool, Set Var)
checkBind (L SrcSpanAnn' b
l a
x) =  forall b a. SrcSpanAnn' b -> (GetCtxt => a) -> GetCtxt => a
updateLoc SrcSpanAnn' b
l forall a b. (a -> b) -> a -> b
$ forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, Set Var)
checkBind a
x
#endif

instance Scope a => Scope (GRHS GhcTc a) where
  check :: GetCtxt => GRHS GhcTc a -> TcM Bool
check (GRHS XCGRHS GhcTc a
_ [GuardLStmt GhcTc]
gs a
b) = do
    (Bool
r, Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, Set Var)
checkBind [GuardLStmt GhcTc]
gs
    Bool
r' <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt`  (forall a. (Scope a, GetCtxt) => a -> TcM Bool
check a
b)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
r')
#if __GLASGOW_HASKELL__ < 900
  check XGRHS{} = return True
#endif

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

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

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

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


-- | Check the scope of a list of (mutual) recursive bindings. The
-- second argument is the set of variables defined by the (mutual)
-- recursive bindings
checkRecursiveBinds :: GetCtxt => [LHsBindLR GhcTc GhcTc] -> Set Var -> TcM (Bool, Set Var)
checkRecursiveBinds :: GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> TcM (Bool, Set Var)
checkRecursiveBinds [LHsBindLR GhcTc GhcTc]
bs Set Var
vs = do
    Bool
res <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' [LHsBindLR GhcTc GhcTc]
bs)
    case Ctxt -> Maybe StableReason
stabilized GetCtxt
?ctxt of
      Just StableReason
reason | Bool
res ->
        (GetCtxt => Severity -> SDoc -> TcM ()
printMessage' Severity
SevWarning (StableReason -> SDoc
recReason StableReason
reason SDoc -> SDoc -> SDoc
<> SDoc
" can cause time leaks")) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, Set Var
vs)
      Maybe StableReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, Set Var
vs)
    where check' :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> TcM Bool
check' b :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b@(L SrcSpanAnnA
l HsBindLR GhcTc GhcTc
_) = SrcSpan -> Ctxt -> Ctxt
fc (forall b. SrcSpanAnn' b -> SrcSpan
getLocAnn' SrcSpanAnnA
l) forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` GetCtxt => LHsBindLR GhcTc GhcTc -> TcM Bool
checkRec GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
          fc :: SrcSpan -> Ctxt -> Ctxt
fc SrcSpan
l Ctxt
c = let
            ctxHid :: Set Var
ctxHid = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c)
            in Ctxt
c {current :: Set Var
current = forall a. Set a
Set.empty,
                  earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left (HiddenReason -> NoTickReason
TickHidden forall a b. (a -> b) -> a -> b
$ StableReason -> HiddenReason
Stabilize forall a b. (a -> b) -> a -> b
$ SrcSpan -> StableReason
StableRec SrcSpan
l),
                  hidden :: Hidden
hidden =  Ctxt -> Hidden
hidden Ctxt
c forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                            (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const (StableReason -> HiddenReason
Stabilize (SrcSpan -> StableReason
StableRec SrcSpan
l))) Set Var
ctxHid),
                  recDef :: Maybe RecDef
recDef = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just (Set Var
vs,SrcSpan
l)) (\(Set Var
vs',SrcSpan
_) -> forall a. a -> Maybe a
Just (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Var
vs' Set Var
vs,SrcSpan
l)) (Ctxt -> Maybe RecDef
recDef Ctxt
c),
                   -- TODO fix location info of recDef (needs one location for each var)
                  stabilized :: Maybe StableReason
stabilized = 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"


#if __GLASGOW_HASKELL__ >= 902
instance ScopeBind (SCC (GenLocated SrcSpanAnnA (HsBindLR  GhcTc GhcTc), Set Var)) where
#else
instance ScopeBind (SCC (LHsBindLR GhcTc GhcTc, Set Var)) where
#endif
  checkBind :: GetCtxt =>
SCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)
-> TcM (Bool, Set Var)
checkBind (AcyclicSCC (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b,Set Var
vs)) = (, Set Var
vs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b
  checkBind (CyclicSCC [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) = GetCtxt =>
[LHsBindLR GhcTc GhcTc] -> Set Var -> TcM (Bool, Set Var)
checkRecursiveBinds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd [(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Set Var)]
bs)
  
instance ScopeBind (HsValBindsLR GhcTc GhcTc) where
  checkBind :: GetCtxt => HsValBindsLR GhcTc GhcTc -> TcM (Bool, Set Var)
checkBind (ValBinds XValBinds GhcTc GhcTc
_ Bag (LHsBindLR GhcTc GhcTc)
bs [LSig GhcTc]
_) = forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, Set Var)
checkBind (Bag (LHsBindLR GhcTc GhcTc)
-> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]
dependency Bag (LHsBindLR GhcTc GhcTc)
bs)
  
  checkBind (XValBindsLR (NValBinds [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds [LSig GhcRn]
_)) = forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, Set Var)
checkBind [(RecFlag, Bag (LHsBindLR GhcTc GhcTc))]
binds


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


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


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

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

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

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


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

arrReason :: StableReason -> a
arrReason StableReason
StableArr = a
"Nested use of arr"
arrReason StableReason
StableBox = a
"The use of arr in the scope of box"
arrReason (StableRec SrcSpan
_) = a
"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
<> forall a. Outputable a => a -> SDoc
ppr SrcSpan
src SDoc -> SDoc -> SDoc
<> SDoc
")"

instance Scope (HsExpr GhcTc) where
  check :: GetCtxt => HsExpr GhcTc -> TcM Bool
check (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
v))
    | Just Prim
p <- GetCtxt => Var -> Maybe Prim
isPrim Var
v =
        case Prim
p of
          Prim
Unbox -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          Prim
_ -> GetCtxt => Severity -> SDoc -> TcM Bool
printMessageCheck Severity
SevError (SDoc
"Defining an alias for " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> SDoc
" is not allowed")
    | Bool
otherwise = case GetCtxt => Var -> VarScope
getScope Var
v of
             Hidden SDoc
reason -> GetCtxt => Severity -> SDoc -> TcM Bool
printMessageCheck Severity
SevError SDoc
reason
             VarScope
Visible -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             VarScope
ImplUnboxed -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
               -- printMessageCheck SevWarning
               --  (ppr v <> text " is an external temporal function used under delay, which may cause time leaks.")
  check (HsApp XApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2) =
    case GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e1 of
    Just (Prim
p,Var
_) -> case Prim
p of
      Prim
Box -> do
        Bool
ch <- StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableBox forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
        case Ctxt -> Maybe StableReason
stabilized GetCtxt
?ctxt of
          Just StableReason
reason | Bool
ch ->
            (GetCtxt => Severity -> SDoc -> TcM ()
printMessage' Severity
SevWarning (forall {a}. IsString a => StableReason -> a
boxReason StableReason
reason SDoc -> SDoc -> SDoc
<> SDoc
" can cause time leaks")) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
          Maybe StableReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
      Prim
Arr -> do
        Bool
ch <- StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableArr forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` 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 of
          Just StableReason
reason | Bool
ch ->
            GetCtxt => Severity -> SDoc -> TcM ()
printMessage' Severity
SevWarning (forall {a}. IsString a => StableReason -> a
arrReason StableReason
reason SDoc -> SDoc -> SDoc
<> SDoc
" can cause time leaks") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
          Maybe StableReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch

      Prim
Unbox -> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
      Prim
Delay ->  ((\Ctxt
c -> Ctxt
c{current :: Set Var
current = forall a. Set a
Set.empty,
                          earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c of
                                      Left NoTickReason
_ -> forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c forall a. a -> [a] -> NonEmpty a
:| [])
                                      Right NonEmpty (Set Var)
cs -> forall a b. b -> Either a b
Right (Ctxt -> Set Var
current Ctxt
c forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (Set Var)
cs)}))
                  forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> TcM Bool
check  LHsExpr GhcTc
e2
      Prim
Adv -> case Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier GetCtxt
?ctxt of
        Right (Set Var
er :| [Set Var]
ers) -> Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` 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 (Set Var))
earlier = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Set Var]
ers of
                                       Maybe (NonEmpty (Set Var))
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
AdvApp
                                       Just NonEmpty (Set Var)
ers' -> forall a b. b -> Either a b
Right NonEmpty (Set Var)
ers',
                           current :: Set Var
current = Set Var
er,
                           hidden :: Hidden
hidden = Ctxt -> Hidden
hidden GetCtxt
?ctxt forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                            forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
AdvApp) (Ctxt -> Set Var
current GetCtxt
?ctxt)}
        Left NoTickReason
NoDelay -> GetCtxt => Severity -> SDoc -> 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
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)
_ -> forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1)  (forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2)
  check HsUnboundVar{}  = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
#if __GLASGOW_HASKELL__ >= 904
  check (HsPar _ _ e _) = check e
  check (HsLamCase _ _ mg) = check mg
  check HsRecSel{} = return True
  check HsTypedBracket{} = notSupported "MetaHaskell"
  check HsUntypedBracket{} = notSupported "MetaHaskell"
#else
  check HsConLikeOut{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsRecFld{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check HsBracket{} = forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check HsRnBracketOut{} = forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
  check HsTcBracketOut{} = forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"MetaHaskell"
#endif
#if __GLASGOW_HASKELL__ >= 904
  check (HsLet _ _ bs _ e) = do
#else
  check (HsLet XLet GhcTc
_ HsLocalBindsLR GhcTc GhcTc
bs LHsExpr GhcTc
e) = do
#endif
    (Bool
l,Set Var
vs) <- forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, Set Var)
checkBind HsLocalBindsLR GhcTc GhcTc
bs
    Bool
r <- Set Var -> Ctxt -> Ctxt
addVars Set Var
vs forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` (forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
r Bool -> Bool -> Bool
&& Bool
l)
         
  check HsOverLabel{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsIPVar{} = forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"implicit parameters"
  check HsOverLit{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True  
  check HsLit{} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check (OpApp XOpApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
  check (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
mg) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsExpr GhcTc)
mg
  check (HsCase XCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsExpr GhcTc)
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e2
  check (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
e Boxity
_) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [HsTupArg GhcTc]
e
  check (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
e SyntaxExpr GhcTc
_) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (ExplicitSum XExplicitSum GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsMultiIf XMultiIf GhcTc
_ [LGRHS GhcTc (LHsExpr GhcTc)]
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LGRHS GhcTc (LHsExpr GhcTc)]
e
#if __GLASGOW_HASKELL__ >= 902
  check (ExplicitList XExplicitList GhcTc
_ [LHsExpr GhcTc]
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsExpr GhcTc]
e
  check HsProjection {} = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  check HsGetField {gf_expr :: forall p. HsExpr p -> LHsExpr p
gf_expr = LHsExpr GhcTc
e} = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
#else
  check (ExplicitList _ _ e) = check e
#endif
  check RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
e, rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
fs} = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check Either [LHsRecUpdField GhcTc] [LHsRecUpdProj GhcTc]
fs
  check RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
f} = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check HsRecordBinds GhcTc
f
  check (ArithSeq XArithSeq GhcTc
_ Maybe (SyntaxExpr GhcTc)
_ ArithSeqInfo GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check ArithSeqInfo GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
  check HsTypedSplice{} = notSupported "Template Haskell"
  check HsUntypedSplice{} = notSupported "Template Haskell"
#else
  check HsSpliceE{} = forall a. (NotSupported a, GetCtxt) => SDoc -> TcM a
notSupported SDoc
"Template Haskell"
#endif
  check (HsProc XProc GhcTc
_ LPat GhcTc
p LHsCmdTop GhcTc
e) = Ctxt -> Ctxt
mod forall a. (Ctxt -> Ctxt) -> (GetCtxt => a) -> GetCtxt => a
`modifyCtxt` forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmdTop GhcTc
e
    where mod :: Ctxt -> Ctxt
mod Ctxt
c = Set Var -> Ctxt -> Ctxt
addVars (forall a. HasBV a => a -> Set Var
getBV LPat GhcTc
p) (StableReason -> Ctxt -> Ctxt
stabilize StableReason
StableArr Ctxt
c)
  check (HsStatic XStatic GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsDo XDo GhcTc
_ HsStmtContext (HsDoRn GhcTc)
_ XRec GhcTc [GuardLStmt GhcTc]
e) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (ScopeBind a, GetCtxt) => a -> TcM (Bool, Set Var)
checkBind XRec GhcTc [GuardLStmt GhcTc]
e
  check (XExpr XXExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check XXExpr GhcTc
e
#if __GLASGOW_HASKELL__ >= 906
  check (HsAppType _ e _ _) = check e
  check (ExprWithTySig _ e _) = check e
#elif __GLASGOW_HASKELL__ >= 808
  check (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = 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 XPragE GhcTc
_ HsPragE GhcTc
_ LHsExpr GhcTc
e) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e
  check (HsIf XIf GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
e2 LHsExpr GhcTc
e3) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Scope a, GetCtxt) => a -> TcM Bool
check [LHsExpr GhcTc
e1,LHsExpr GhcTc
e2,LHsExpr GhcTc
e3]
#else
  check (HsSCC _ _ _ e) = check e
  check (HsCoreAnn _ _ _ e) = check e
  check (HsTickPragma _ _ _ _ e) = check e
  check (HsWrap _ _ e) = check e
  check (HsIf _ _ e1 e2 e3) = and <$> mapM check [e1,e2,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

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


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


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

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

  check (HsCmdCase XCmdCase GhcTc
_ LHsExpr GhcTc
e1 MatchGroup GhcTc (LHsCmd GhcTc)
e2) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check MatchGroup GhcTc (LHsCmd GhcTc)
e2
  check (HsCmdIf XCmdIf GhcTc
_ SyntaxExpr GhcTc
_ LHsExpr GhcTc
e1 LHsCmd GhcTc
e2 LHsCmd GhcTc
e3) = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsExpr GhcTc
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Scope a, GetCtxt) => a -> TcM Bool
check LHsCmd GhcTc
e3
#if __GLASGOW_HASKELL__ >= 900
  check (XCmd (HsWrap HsWrapper
_ HsCmd GhcTc
e)) = forall a. (Scope a, GetCtxt) => a -> TcM Bool
check HsCmd GhcTc
e
#else
  check (HsCmdWrap _ _ e) = check e
  check XCmd{} = return True
#endif


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

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



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

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

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



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

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


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


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


checkSCC' ::  Module -> AnnEnv -> SCC (LHsBindLR  GhcTc GhcTc, Set Var) -> TcM (Bool, [ErrorMsg])
checkSCC' :: Module
-> AnnEnv
-> SCC (LHsBindLR GhcTc GhcTc, Set Var)
-> TcM (Bool, [ErrorMsg])
checkSCC' Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc = do
  ErrorMsgsRef
err <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (IORef a)
newIORef [])
  let allowRec :: Bool
allowRec = Rattus
AllowRecursion forall a. Ord a => a -> Set a -> Bool
`Set.member` forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
  Bool
res <- Bool
-> ErrorMsgsRef -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> TcM Bool
checkSCC Bool
allowRec ErrorMsgsRef
err SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
  [ErrorMsg]
msgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef ErrorMsgsRef
err)
  let anns :: Set InternalAnn
anns = forall a.
(Data a, Ord a) =>
Module -> AnnEnv -> SCC (LHsBindLR GhcTc GhcTc, Set Var) -> Set a
getAnn Module
mod AnnEnv
anEnv SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc
  if InternalAnn
ExpectWarning forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns 
    then if InternalAnn
ExpectError forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
         then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Annotation to expect both warning and error is not allowed.")])
         else if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
True; Severity
_ -> Bool
False) [ErrorMsg]
msgs
              then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, forall a. (a -> Bool) -> [a] -> [a]
filter (\(Severity
s,SrcSpan
_,SDoc
_) -> case Severity
s of Severity
SevWarning -> Bool
False; Severity
_ -> Bool
True) [ErrorMsg]
msgs)
              else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Warning was expected, but typechecking produced no warning.")])
    else if InternalAnn
ExpectError forall a. Ord a => a -> Set a -> Bool
`Set.member` Set InternalAnn
anns
         then if Bool
res
              then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[(Severity
SevError, SCC (LHsBindLR GhcTc GhcTc, Set Var) -> SrcSpan
getSCCLoc SCC (LHsBindLR GhcTc GhcTc, Set Var)
scc, SDoc
"Error was expected, but typechecking produced no error.")])
              else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[])
         else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
res, [ErrorMsg]
msgs)

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



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

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

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

-- | Stabilizes the given context, i.e. remove all non-stable types
-- and any tick. This is performed on checking 'box', '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 :: Set Var
current = forall a. Set a
Set.empty,
   earlier :: Either NoTickReason (NonEmpty (Set Var))
earlier = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HiddenReason -> NoTickReason
TickHidden HiddenReason
hr,
   hidden :: Hidden
hidden = Ctxt -> Hidden
hidden Ctxt
c forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const HiddenReason
hr) Set Var
ctxHid,
   stabilized :: Maybe StableReason
stabilized = forall a. a -> Maybe a
Just StableReason
sr}
  where ctxHid :: Set Var
ctxHid = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Ctxt -> Set Var
current Ctxt
c) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctxt -> Set Var
current Ctxt
c)) (Ctxt -> Either NoTickReason (NonEmpty (Set Var))
earlier Ctxt
c)
        hr :: HiddenReason
hr = StableReason -> HiddenReason
Stabilize StableReason
sr

data VarScope = Hidden SDoc | Visible | ImplUnboxed


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

-- | A map from the syntax of a primitive of Rattus to 'Prim'.
primMap :: Map FastString Prim
primMap :: Map FastString Prim
primMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [(FastString
"Delay", Prim
Delay),
   (FastString
"delay", Prim
Delay),
   (FastString
"adv", Prim
Adv),
   (FastString
"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 :: GetCtxt => Var -> Maybe Prim
isPrim Var
v
  | Just Prim
p <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctxt -> Map Var Prim
primAlias GetCtxt
?ctxt) = forall a. a -> Maybe a
Just Prim
p
  | Bool
otherwise = do
  (FastString
name,FastString
mod) <- forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule Var
v
  if FastString -> Bool
isRattModule FastString
mod then forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FastString
name Map FastString Prim
primMap
  else forall a. Maybe a
Nothing


-- | Checks whether a given expression is in fact a Rattus primitive.
isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim,Var)
isPrimExpr :: GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr (L SrcSpanAnnA
_ HsExpr GhcTc
e) = GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' HsExpr GhcTc
e where
  isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var)
  isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr' (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
v)) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Var
v) (GetCtxt => Var -> Maybe Prim
isPrim Var
v)
#if __GLASGOW_HASKELL__ >= 906
  isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e
#elif __GLASGOW_HASKELL__ >= 808
  isPrimExpr' (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_) = GetCtxt => LHsExpr GhcTc -> Maybe (Prim, Var)
isPrimExpr LHsExpr GhcTc
e
#else
  isPrimExpr' (HsAppType _ e)   = isPrimExpr e
#endif

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

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


-- | This type class provides default implementations for 'check' and
-- 'checkBind' for Haskell syntax that is not supported. These default
-- implementations simply print an error message.
class NotSupported a where
  notSupported :: GetCtxt => SDoc -> TcM a

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

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


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

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

-- | Print a message with the current location. Returns 'False', if
-- the severity is 'SevError' and otherwise 'True.
printMessageCheck :: GetCtxt =>  Severity -> SDoc -> TcM Bool
printMessageCheck :: GetCtxt => Severity -> SDoc -> TcM Bool
printMessageCheck Severity
sev SDoc
doc = GetCtxt => Severity -> SDoc -> TcM ()
printMessage' Severity
sev SDoc
doc forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  case Severity
sev of
    Severity
SevError -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Severity
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True