{-# LANGUAGE GADTs #-} -- for 8.10
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Debug.Breakpoint.Renamer
  ( renameAction
  ) where

import           Control.Applicative ((<|>), empty)
import           Control.Arrow ((&&&))
import           Control.Monad.Reader
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Writer.CPS
import           Data.Data hiding (IntRep, FloatRep)
import qualified Data.Graph as Graph
import qualified Data.Map.Lazy as M
import           Data.Maybe
import           Data.Monoid (Any(..))
import           Data.Traversable (for)

import qualified Debug.Breakpoint.GhcFacade as Ghc

renameAction
  :: Ghc.TcGblEnv
  -> Ghc.HsGroup Ghc.GhcRn
  -> Ghc.TcM (Ghc.TcGblEnv, Ghc.HsGroup Ghc.GhcRn)
renameAction :: TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
renameAction TcGblEnv
gblEnv HsGroup (GhcPass 'Renamed)
group = do
  Ghc.Found ModLocation
_ Module
breakpointMod <-
    ModuleName -> TcM FindResult
Ghc.findPluginModule' (String -> ModuleName
Ghc.mkModuleName String
"Debug.Breakpoint")

  Name
captureVarsName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"captureVars")
  Name
showLevName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"showLev")
  Name
fromListName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"fromAscList")
  Name
breakpointName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"breakpoint")
  Name
queryVarsName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"queryVars")
  Name
breakpointMName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"breakpointM")
  Name
queryVarsMName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"queryVarsM")
  Name
breakpointIOName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"breakpointIO")
  Name
queryVarsIOName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"queryVarsIO")
  Name
printAndWaitName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"printAndWait")
  Name
printAndWaitMName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"printAndWaitM")
  Name
printAndWaitIOName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"printAndWaitIO")
  Name
runPromptIOName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"runPromptIO")
  Name
runPromptMName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"runPromptM")
  Name
runPromptName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"runPrompt")
  Name
getSrcLocName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"getSrcLoc")
  Name
excludeVarsName <- forall a b. Module -> OccName -> TcRnIf a b Name
Ghc.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkVarOcc String
"excludeVars")

  (HsGroup (GhcPass 'Renamed)
group', Any
_) <-
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse HsGroup (GhcPass 'Renamed)
group)
      MkEnv { varSet :: VarSet
varSet = forall a. Monoid a => a
mempty, Name
excludeVarsName :: Name
getSrcLocName :: Name
runPromptMName :: Name
runPromptName :: Name
runPromptIOName :: Name
printAndWaitIOName :: Name
printAndWaitMName :: Name
printAndWaitName :: Name
queryVarsIOName :: Name
breakpointIOName :: Name
queryVarsMName :: Name
breakpointMName :: Name
queryVarsName :: Name
breakpointName :: Name
fromListName :: Name
showLevName :: Name
captureVarsName :: Name
excludeVarsName :: Name
getSrcLocName :: Name
runPromptName :: Name
runPromptMName :: Name
runPromptIOName :: Name
printAndWaitIOName :: Name
printAndWaitMName :: Name
printAndWaitName :: Name
queryVarsIOName :: Name
breakpointIOName :: Name
queryVarsMName :: Name
breakpointMName :: Name
queryVarsName :: Name
breakpointName :: Name
fromListName :: Name
showLevName :: Name
captureVarsName :: Name
.. }

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcGblEnv
gblEnv, HsGroup (GhcPass 'Renamed)
group')

recurse :: Data a => a -> EnvReader a
recurse :: forall a. Data a => a -> EnvReader a
recurse a
a =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM forall a. Data a => a -> EnvReader a
recurse a
a) forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Data a => a -> EnvReader (Maybe a)
transform a
a

newtype T a = T (a -> EnvReader (Maybe a))

transform :: forall a. Data a => a -> EnvReader (Maybe a)
transform :: forall a. Data a => a -> EnvReader (Maybe a)
transform a
a = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
      forall a b. (a -> b) -> a -> b
$ forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsVarCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap LHsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (LHsExpr (GhcPass 'Renamed)))
hsAppCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap Match (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (Match (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
matchCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
grhssCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsLetCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap GRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (GRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
grhsCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsDoCase
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsProcCase
  where
    wrap :: forall b. Data b
         => (b -> EnvReader (Maybe b))
         -> MaybeT EnvReader a
    wrap :: forall b.
Data b =>
(b -> EnvReader (Maybe b))
-> MaybeT (WriterT Any (ReaderT Env TcM)) a
wrap b -> EnvReader (Maybe b)
f = do
      case forall {k} (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast @b @a (forall a. (a -> EnvReader (Maybe a)) -> T a
T b -> EnvReader (Maybe b)
f) of
        Maybe (T a)
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
        Just (T a -> WriterT Any (ReaderT Env TcM) (Maybe a)
f') -> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ a -> WriterT Any (ReaderT Env TcM) (Maybe a)
f' a
a

--------------------------------------------------------------------------------
-- Variable Expr
--------------------------------------------------------------------------------

hsVarCase :: Ghc.HsExpr Ghc.GhcRn
          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))
hsVarCase :: HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsVarCase (Ghc.HsVar XVar (GhcPass 'Renamed)
_ (Ghc.L SrcSpanAnnN
loc Name
name)) = do
  MkEnv{VarSet
Name
excludeVarsName :: Name
getSrcLocName :: Name
runPromptMName :: Name
runPromptName :: Name
runPromptIOName :: Name
printAndWaitIOName :: Name
printAndWaitMName :: Name
printAndWaitName :: Name
queryVarsIOName :: Name
breakpointIOName :: Name
queryVarsMName :: Name
breakpointMName :: Name
queryVarsName :: Name
breakpointName :: Name
fromListName :: Name
showLevName :: Name
captureVarsName :: Name
varSet :: VarSet
excludeVarsName :: Env -> Name
getSrcLocName :: Env -> Name
runPromptMName :: Env -> Name
runPromptName :: Env -> Name
runPromptIOName :: Env -> Name
printAndWaitIOName :: Env -> Name
printAndWaitMName :: Env -> Name
printAndWaitName :: Env -> Name
queryVarsIOName :: Env -> Name
breakpointIOName :: Env -> Name
queryVarsMName :: Env -> Name
breakpointMName :: Env -> Name
queryVarsName :: Env -> Name
breakpointName :: Env -> Name
fromListName :: Env -> Name
showLevName :: Env -> Name
captureVarsName :: Env -> Name
varSet :: Env -> VarSet
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask

  let srcLocStringExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr
        = forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). String -> HsLit (GhcPass p)
Ghc.mkHsString
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> String
Ghc.showSDocUnsafe
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
Ghc.ppr
        forall a b. (a -> b) -> a -> b
$ forall a. SrcSpanAnn' a -> SrcSpan
Ghc.locA SrcSpanAnnN
loc

      captureVarsExpr :: Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr Maybe Name
mResultName =
        let mkTuple :: (LexicalFastString, Name) -> LHsExpr (GhcPass 'Renamed)
mkTuple (LexicalFastString -> FastString
Ghc.fromLexicalFastString -> FastString
varStr, Name
n) =
              forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.mkLHsTupleExpr
                [ forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). String -> HsLit (GhcPass p)
Ghc.mkHsString forall a b. (a -> b) -> a -> b
$ FastString -> String
Ghc.unpackFS FastString
varStr
                , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
showLevName) (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
n)
                ]
                NoExtField
Ghc.NoExtField

            mkList :: [XRec p (HsExpr p)] -> LocatedAn an (HsExpr p)
mkList [XRec p (HsExpr p)]
exprs = forall a an. a -> LocatedAn an a
Ghc.noLocA (forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
Ghc.ExplicitList NoExtField
Ghc.NoExtField [XRec p (HsExpr p)]
exprs)

            varSetWithResult :: VarSet
varSetWithResult
              | Just Name
resName <- Maybe Name
mResultName =
                  forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FastString -> LexicalFastString
Ghc.mkLexicalFastString forall a b. (a -> b) -> a -> b
$ String -> FastString
Ghc.mkFastString String
"*result")
                           Name
resName
                           VarSet
varSet
              | Bool
otherwise = VarSet
varSet

         in forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
fromListName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p} {an}.
(XExplicitList p ~ NoExtField) =>
[XRec p (HsExpr p)] -> LocatedAn an (HsExpr p)
mkList
              forall a b. (a -> b) -> a -> b
$ (LexicalFastString, Name) -> LHsExpr (GhcPass 'Renamed)
mkTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList VarSet
varSetWithResult

      bpExpr :: IOEnv
  (Env TcGblEnv TcLclEnv)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
bpExpr = do
        Name
resultName <- OccName -> TcM Name
Ghc.newName (NameSpace -> String -> OccName
Ghc.mkOccName NameSpace
Ghc.varName String
"_result_")
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.mkHsLam [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
Ghc.nlVarPat Name
resultName] forall a b. (a -> b) -> a -> b
$
            forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
              (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
                (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
printAndWaitName) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)
                (Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Name
resultName)
              )
              (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
resultName)

      bpMExpr :: LHsExpr (GhcPass 'Renamed)
bpMExpr =
        forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
printAndWaitMName) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)
          forall a b. (a -> b) -> a -> b
$ Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a. Maybe a
Nothing

      bpIOExpr :: LHsExpr (GhcPass 'Renamed)
bpIOExpr =
        forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
printAndWaitIOName) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)
          forall a b. (a -> b) -> a -> b
$ Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a. Maybe a
Nothing

      queryVarsIOExpr :: LHsExpr (GhcPass 'Renamed)
queryVarsIOExpr =
        forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
runPromptIOName) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)
          forall a b. (a -> b) -> a -> b
$ Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a. Maybe a
Nothing

      queryVarsExpr :: IOEnv
  (Env TcGblEnv TcLclEnv)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
queryVarsExpr = do
        Name
resultName <- OccName -> TcM Name
Ghc.newName (NameSpace -> String -> OccName
Ghc.mkOccName NameSpace
Ghc.varName String
"_result_")
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.mkHsLam [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
Ghc.nlVarPat Name
resultName] forall a b. (a -> b) -> a -> b
$
            forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
              (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
                (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
runPromptName) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)
                (Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Name
resultName)
              )
              (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
resultName)

      queryVarsMExpr :: LHsExpr (GhcPass 'Renamed)
queryVarsMExpr =
        forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsVar Name
runPromptMName) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)
          forall a b. (a -> b) -> a -> b
$ Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a. Maybe a
Nothing

  if | Name
captureVarsName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
Ghc.unLoc forall a b. (a -> b) -> a -> b
$ Maybe Name -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr forall a. Maybe a
Nothing)

     | Name
breakpointName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
Ghc.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv
  (Env TcGblEnv TcLclEnv)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
bpExpr)

     | Name
breakpointMName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LHsExpr (GhcPass 'Renamed)
bpMExpr)

     | Name
breakpointIOName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LHsExpr (GhcPass 'Renamed)
bpIOExpr)

     | Name
queryVarsIOName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LHsExpr (GhcPass 'Renamed)
queryVarsIOExpr)

     | Name
queryVarsName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
Ghc.unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv
  (Env TcGblEnv TcLclEnv)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
queryVarsExpr)

     | Name
queryVarsMName forall a. Eq a => a -> a -> Bool
== Name
name -> do
         forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LHsExpr (GhcPass 'Renamed)
queryVarsMExpr)

     | Name
getSrcLocName forall a. Eq a => a -> a -> Bool
== Name
name ->
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr)

     | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
hsVarCase HsExpr (GhcPass 'Renamed)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- App Expr
--------------------------------------------------------------------------------

hsAppCase :: Ghc.LHsExpr Ghc.GhcRn
          -> EnvReader (Maybe (Ghc.LHsExpr Ghc.GhcRn))
hsAppCase :: LHsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (LHsExpr (GhcPass 'Renamed)))
hsAppCase (forall l e. GenLocated l e -> e
Ghc.unLoc -> Ghc.HsApp XApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
f LHsExpr (GhcPass 'Renamed)
innerExpr)
  | Ghc.HsApp XApp (GhcPass 'Renamed)
_ (forall l e. GenLocated l e -> e
Ghc.unLoc -> Ghc.HsVar XVar (GhcPass 'Renamed)
_ (forall l e. GenLocated l e -> e
Ghc.unLoc -> Name
name))
                (forall l e. GenLocated l e -> e
Ghc.unLoc -> Ghc.ExplicitList' XExplicitList (GhcPass 'Renamed)
_ [LHsExpr (GhcPass 'Renamed)]
exprsToExclude)
      <- forall l e. GenLocated l e -> e
Ghc.unLoc LHsExpr (GhcPass 'Renamed)
f
  = do
    MkEnv{VarSet
Name
excludeVarsName :: Name
getSrcLocName :: Name
runPromptMName :: Name
runPromptName :: Name
runPromptIOName :: Name
printAndWaitIOName :: Name
printAndWaitMName :: Name
printAndWaitName :: Name
queryVarsIOName :: Name
breakpointIOName :: Name
queryVarsMName :: Name
breakpointMName :: Name
queryVarsName :: Name
breakpointName :: Name
fromListName :: Name
showLevName :: Name
captureVarsName :: Name
varSet :: VarSet
excludeVarsName :: Env -> Name
getSrcLocName :: Env -> Name
runPromptMName :: Env -> Name
runPromptName :: Env -> Name
runPromptIOName :: Env -> Name
printAndWaitIOName :: Env -> Name
printAndWaitMName :: Env -> Name
printAndWaitName :: Env -> Name
queryVarsIOName :: Env -> Name
breakpointIOName :: Env -> Name
queryVarsMName :: Env -> Name
breakpointMName :: Env -> Name
queryVarsName :: Env -> Name
breakpointName :: Env -> Name
fromListName :: Env -> Name
showLevName :: Env -> Name
captureVarsName :: Env -> Name
varSet :: Env -> VarSet
..} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
    if Name
excludeVarsName forall a. Eq a => a -> a -> Bool
/= Name
name
       then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
       else do
         let extractVarName :: HsExpr (GhcPass 'Renamed) -> Maybe LexicalFastString
extractVarName (Ghc.HsLit XLitE (GhcPass 'Renamed)
_ (Ghc.HsString XHsString (GhcPass 'Renamed)
_ FastString
fs)) =
               forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FastString -> LexicalFastString
Ghc.mkLexicalFastString FastString
fs
             extractVarName (Ghc.HsOverLit XOverLitE (GhcPass 'Renamed)
_ (Ghc.OverLit' (Ghc.HsIsString SourceText
_ FastString
fs))) =
               forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FastString -> LexicalFastString
Ghc.mkLexicalFastString FastString
fs
             extractVarName HsExpr (GhcPass 'Renamed)
_ = forall a. Maybe a
Nothing

             varsToExclude :: [LexicalFastString]
varsToExclude =
               forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HsExpr (GhcPass 'Renamed) -> Maybe LexicalFastString
extractVarName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
Ghc.unLoc) [LHsExpr (GhcPass 'Renamed)]
exprsToExclude

         forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           forall (n :: * -> *) w w' (m :: * -> *) a b.
(Monad n, Monoid w, Monoid w') =>
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT
            (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((VarSet -> VarSet) -> Env -> Env
overVarSet forall a b. (a -> b) -> a -> b
$ \VarSet
vs -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall k a. Ord k => k -> Map k a -> Map k a
M.delete VarSet
vs [LexicalFastString]
varsToExclude))
            (forall a. Data a => a -> EnvReader a
recurse LHsExpr (GhcPass 'Renamed)
innerExpr)
hsAppCase LHsExpr (GhcPass 'Renamed)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Match
--------------------------------------------------------------------------------

matchCase :: Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
          -> EnvReader (Maybe (Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))
matchCase :: Match (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (Match (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
matchCase Ghc.Match {[LPat (GhcPass 'Renamed)]
HsMatchContext (NoGhcTc (GhcPass 'Renamed))
GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
XCMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m_ctxt :: forall p body. Match p body -> HsMatchContext (NoGhcTc p)
m_ext :: forall p body. Match p body -> XCMatch p body
m_grhss :: forall p body. Match p body -> GRHSs p body
m_pats :: forall p body. Match p body -> [LPat p]
m_grhss :: GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m_pats :: [LPat (GhcPass 'Renamed)]
m_ctxt :: HsMatchContext (NoGhcTc (GhcPass 'Renamed))
m_ext :: XCMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
..} = do
  let names :: VarSet
names = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LPat (GhcPass 'Renamed) -> VarSet
extractVarPats [LPat (GhcPass 'Renamed)]
m_pats
  GRHSs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
grhRes <- forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m_grhss
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
    Ghc.Match { m_grhss :: GRHSs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
Ghc.m_grhss = GRHSs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
grhRes, [LPat (GhcPass 'Renamed)]
HsMatchContext (NoGhcTc (GhcPass 'Renamed))
XCMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m_ctxt :: HsMatchContext (NoGhcTc (GhcPass 'Renamed))
m_ext :: XCMatch
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
m_pats :: [LPat (GhcPass 'Renamed)]
m_pats :: [LPat (GhcPass 'Renamed)]
m_ctxt :: HsMatchContext (NoGhcTc (GhcPass 'Renamed))
m_ext :: XCMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
.. }

extractVarPats :: Ghc.LPat Ghc.GhcRn -> VarSet
extractVarPats :: LPat (GhcPass 'Renamed) -> VarSet
extractVarPats = [Name] -> VarSet
mkVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat (GhcPass 'Renamed) -> [Name]
Ghc.collectPatBinders'

--------------------------------------------------------------------------------
-- Guarded Right-hand Sides
--------------------------------------------------------------------------------

grhssCase :: Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
         -> EnvReader (Maybe (Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))
grhssCase :: GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
grhssCase Ghc.GRHSs {[LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
HsLocalBinds (GhcPass 'Renamed)
XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhssExt :: forall p body. GRHSs p body -> XCGRHSs p body
grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds :: HsLocalBinds (GhcPass 'Renamed)
grhssGRHSs :: [LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
grhssExt :: XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
..} = do
  (HsLocalBinds (GhcPass 'Renamed)
localBindsRes, VarSet
names)
    <- HsLocalBinds (GhcPass 'Renamed)
-> EnvReader (HsLocalBinds (GhcPass 'Renamed), VarSet)
dealWithLocalBinds
         HsLocalBinds (GhcPass 'Renamed)
grhssLocalBinds

  [GenLocated
   SrcSpan
   (GRHS
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
grhsRes <- forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse [LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
grhssGRHSs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
    Ghc.GRHSs { grhssGRHSs :: [LGRHS
   (GhcPass 'Renamed)
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
Ghc.grhssGRHSs = [GenLocated
   SrcSpan
   (GRHS
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
grhsRes
              , grhssLocalBinds :: HsLocalBinds (GhcPass 'Renamed)
grhssLocalBinds = HsLocalBinds (GhcPass 'Renamed)
localBindsRes
              , XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhssExt :: XCGRHSs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
grhssExt :: XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
..
              }

dealWithBind :: VarSet
             -> Ghc.LHsBind Ghc.GhcRn
             -> EnvReader (Ghc.LHsBind Ghc.GhcRn)
dealWithBind :: VarSet
-> LHsBind (GhcPass 'Renamed)
-> EnvReader (LHsBind (GhcPass 'Renamed))
dealWithBind VarSet
resultNames LHsBind (GhcPass 'Renamed)
lbind = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for LHsBind (GhcPass 'Renamed)
lbind forall a b. (a -> b) -> a -> b
$ \case
  Ghc.FunBind {[CoreTickish]
MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
LIdP (GhcPass 'Renamed)
XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick :: [CoreTickish]
fun_matches :: MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
fun_id :: LIdP (GhcPass 'Renamed)
fun_ext :: XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
..} -> do
    let resultNamesSansSelf :: VarSet
resultNamesSansSelf =
          forall k a. Ord k => k -> Map k a -> Map k a
M.delete (Name -> LexicalFastString
getOccNameFS forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc LIdP (GhcPass 'Renamed)
fun_id) VarSet
resultNames
    (MatchGroup
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
matchesRes, Any Bool
containsTarget)
      <- forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
resultNamesSansSelf
       forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
fun_matches
    -- be sure to use the result names on the right so that they are overriden
    -- by any shadowing vars inside the expr.
    let rhsVars :: UniqSet Name
rhsVars
          | Bool
containsTarget
          = forall a. Uniquable a => [a] -> UniqSet a
Ghc.mkUniqSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> VarSet
resultNamesSansSelf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> VarSet
mkVarSet
            forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext
          | Bool
otherwise = XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Ghc.FunBind { fun_matches :: MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
Ghc.fun_matches = MatchGroup
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
matchesRes, fun_ext :: XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
Ghc.fun_ext = UniqSet Name
rhsVars, [CoreTickish]
LIdP (GhcPass 'Renamed)
fun_id :: LIdP (GhcPass 'Renamed)
fun_tick :: [CoreTickish]
fun_tick :: [CoreTickish]
fun_id :: LIdP (GhcPass 'Renamed)
.. }

  Ghc.PatBind {([CoreTickish], [[CoreTickish]])
GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
LPat (GhcPass 'Renamed)
XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_ticks :: forall idL idR.
HsBindLR idL idR -> ([CoreTickish], [[CoreTickish]])
pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_rhs :: GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
pat_lhs :: LPat (GhcPass 'Renamed)
pat_ext :: XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
..} -> do
    (GRHSs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
rhsRes, Any Bool
containsTarget)
      <- forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
resultNames
       forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
pat_rhs
    let rhsVars :: UniqSet Name
rhsVars
          | Bool
containsTarget
          = forall a. Uniquable a => [a] -> UniqSet a
Ghc.mkUniqSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> VarSet
resultNames) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> VarSet
mkVarSet
            forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ext
          | Bool
otherwise = XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ext
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Ghc.PatBind { pat_rhs :: GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
Ghc.pat_rhs = GRHSs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
rhsRes, pat_ext :: XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ext = UniqSet Name
rhsVars, ([CoreTickish], [[CoreTickish]])
LPat (GhcPass 'Renamed)
pat_lhs :: LPat (GhcPass 'Renamed)
pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_lhs :: LPat (GhcPass 'Renamed)
.. }

  -- Does this not occur in the renamer?
  Ghc.VarBind {XVarBind (GhcPass 'Renamed) (GhcPass 'Renamed)
LHsExpr (GhcPass 'Renamed)
IdP (GhcPass 'Renamed)
var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs :: LHsExpr (GhcPass 'Renamed)
var_id :: IdP (GhcPass 'Renamed)
var_ext :: XVarBind (GhcPass 'Renamed) (GhcPass 'Renamed)
..} -> do
    GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rhsRes
      <- forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
resultNames
       forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse LHsExpr (GhcPass 'Renamed)
var_rhs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Ghc.VarBind { var_rhs :: LHsExpr (GhcPass 'Renamed)
Ghc.var_rhs = GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
rhsRes, XVarBind (GhcPass 'Renamed) (GhcPass 'Renamed)
IdP (GhcPass 'Renamed)
var_ext :: XVarBind (GhcPass 'Renamed) (GhcPass 'Renamed)
var_id :: IdP (GhcPass 'Renamed)
var_id :: IdP (GhcPass 'Renamed)
var_ext :: XVarBind (GhcPass 'Renamed) (GhcPass 'Renamed)
.. }

  Ghc.PatSynBind XPatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
x Ghc.PSB {HsPatSynDir (GhcPass 'Renamed)
HsPatSynDetails (GhcPass 'Renamed)
LPat (GhcPass 'Renamed)
LIdP (GhcPass 'Renamed)
XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_ext :: forall idL idR. PatSynBind idL idR -> XPSB idL idR
psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_dir :: HsPatSynDir (GhcPass 'Renamed)
psb_def :: LPat (GhcPass 'Renamed)
psb_args :: HsPatSynDetails (GhcPass 'Renamed)
psb_id :: LIdP (GhcPass 'Renamed)
psb_ext :: XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
..} -> do
    (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
defRes, Any Bool
containsTarget)
      <- forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
resultNames
       forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse LPat (GhcPass 'Renamed)
psb_def
    let rhsVars :: UniqSet Name
rhsVars
          | Bool
containsTarget
          = forall a. Uniquable a => [a] -> UniqSet a
Ghc.mkUniqSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> VarSet
resultNames) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> VarSet
mkVarSet
            forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_ext
          | Bool
otherwise = XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_ext
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
Ghc.PatSynBind XPatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
x Ghc.PSB { psb_def :: LPat (GhcPass 'Renamed)
psb_def = GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
defRes, psb_ext :: XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_ext = UniqSet Name
rhsVars, HsPatSynDir (GhcPass 'Renamed)
HsPatSynDetails (GhcPass 'Renamed)
LIdP (GhcPass 'Renamed)
psb_args :: HsPatSynDetails (GhcPass 'Renamed)
psb_dir :: HsPatSynDir (GhcPass 'Renamed)
psb_id :: LIdP (GhcPass 'Renamed)
psb_dir :: HsPatSynDir (GhcPass 'Renamed)
psb_args :: HsPatSynDetails (GhcPass 'Renamed)
psb_id :: LIdP (GhcPass 'Renamed)
.. }

#if !MIN_VERSION_ghc(9,4,0)
  HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
other -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
other
#endif

grhsCase :: Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
         -> EnvReader (Maybe (Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))
grhsCase :: GRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (GRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
grhsCase (Ghc.GRHS XCGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
x [GuardLStmt (GhcPass 'Renamed)]
guards LHsExpr (GhcPass 'Renamed)
body) = do
  ([GenLocated
   (Anno
      (Stmt
         (GhcPass 'Renamed)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
guardsRes, VarSet
names) <- forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     [LStmt (GhcPass 'Renamed) body]
dealWithStatements [GuardLStmt (GhcPass 'Renamed)]
guards
  GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
bodyRes <- forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse LHsExpr (GhcPass 'Renamed)
body
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
x [GenLocated
   (Anno
      (Stmt
         (GhcPass 'Renamed)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
guardsRes GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
bodyRes

--------------------------------------------------------------------------------
-- Let Binds (Non-do)
--------------------------------------------------------------------------------

-- TODO could combine with hsVar case to allow for "quick failure"
hsLetCase :: Ghc.HsExpr Ghc.GhcRn
          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))
hsLetCase :: HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsLetCase (Ghc.HsLet' XLet (GhcPass 'Renamed)
x ()
letToken (Ghc.L SrcSpan
loc HsLocalBinds (GhcPass 'Renamed)
localBinds) ()
inToken LHsExpr (GhcPass 'Renamed)
inExpr) = do
  (HsLocalBinds (GhcPass 'Renamed)
bindsRes, VarSet
names) <- HsLocalBinds (GhcPass 'Renamed)
-> EnvReader (HsLocalBinds (GhcPass 'Renamed), VarSet)
dealWithLocalBinds HsLocalBinds (GhcPass 'Renamed)
localBinds

  GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
inExprRes <- forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse LHsExpr (GhcPass 'Renamed)
inExpr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    XLet (GhcPass 'Renamed)
-> ()
-> GenLocated SrcSpan (HsLocalBinds (GhcPass 'Renamed))
-> ()
-> LHsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed)
Ghc.HsLet' XLet (GhcPass 'Renamed)
x ()
letToken (forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
loc HsLocalBinds (GhcPass 'Renamed)
bindsRes) ()
inToken GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
inExprRes
hsLetCase HsExpr (GhcPass 'Renamed)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

dealWithLocalBinds
  :: Ghc.HsLocalBinds Ghc.GhcRn
  -> EnvReader (Ghc.HsLocalBinds Ghc.GhcRn, VarSet)
dealWithLocalBinds :: HsLocalBinds (GhcPass 'Renamed)
-> EnvReader (HsLocalBinds (GhcPass 'Renamed), VarSet)
dealWithLocalBinds = \case
  hlb :: HsLocalBinds (GhcPass 'Renamed)
hlb@(Ghc.HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
x HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
valBinds) -> case HsValBindsLR (GhcPass 'Renamed) (GhcPass 'Renamed)
valBinds of
    Ghc.ValBinds{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsLocalBinds (GhcPass 'Renamed)
hlb, forall a. Monoid a => a
mempty)
    Ghc.XValBindsLR (Ghc.NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
bindPairs [LSig (GhcPass 'Renamed)]
sigs) -> do
      let binds :: [LHsBind (GhcPass 'Renamed)]
binds = forall a. Bag a -> [a]
Ghc.bagToList
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Bag a] -> Bag a
Ghc.unionManyBags
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds (GhcPass 'Renamed))]
bindPairs :: [Ghc.LHsBind Ghc.GhcRn]
          names :: [[Name]]
names = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall idR. HsBindLR (GhcPass 'Renamed) idR -> [Name]
Ghc.collectHsBindBinders')
                      [LHsBind (GhcPass 'Renamed)]
binds
          resultNames :: VarSet
resultNames = [Name] -> VarSet
mkVarSet forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
names

      ([(GenLocated
    SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
  [Name])]
resBindsWithNames, Any Bool
containsTarget)
        <- forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [a] -> [b] -> [(a, b)]
`zip` [[Name]]
names)
         forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (VarSet
-> LHsBind (GhcPass 'Renamed)
-> EnvReader (LHsBind (GhcPass 'Renamed))
dealWithBind VarSet
resultNames) [LHsBind (GhcPass 'Renamed)]
binds

      if Bool -> Bool
not Bool
containsTarget
         then forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsLocalBinds (GhcPass 'Renamed)
hlb, VarSet
resultNames) -- if no bind contained the target then we're done
         else do
           -- Need to reorder the binds because the variables references on the
           -- RHS of some binds have changed
           let mkTuple :: (t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)), b)
-> (t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)), b,
    UniqSet Name)
mkTuple (t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind, b
ns)
                 = (t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind, b
ns, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> UniqSet Name
getRhsFreeVars t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind)

               finalResult :: [(RecFlag, LHsBinds (GhcPass 'Renamed))]
finalResult = [(LHsBind (GhcPass 'Renamed), [Name], UniqSet Name)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
depAnalBinds forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {b}.
Foldable t =>
(t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)), b)
-> (t (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)), b,
    UniqSet Name)
mkTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(GenLocated
    SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
  [Name])]
resBindsWithNames

           forall (f :: * -> *) a. Applicative f => a -> f a
pure ( forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
Ghc.HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
x
                    forall a b. (a -> b) -> a -> b
$ forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
Ghc.XValBindsLR
                        forall a b. (a -> b) -> a -> b
$ forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
Ghc.NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
finalResult [LSig (GhcPass 'Renamed)]
sigs
                , VarSet
resultNames
                )

  x :: HsLocalBinds (GhcPass 'Renamed)
x@(Ghc.HsIPBinds XHsIPBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
_ HsIPBinds (GhcPass 'Renamed)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsLocalBinds (GhcPass 'Renamed)
x, forall a. Monoid a => a
mempty) -- TODO ImplicitParams

  HsLocalBinds (GhcPass 'Renamed)
other -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsLocalBinds (GhcPass 'Renamed)
other, forall a. Monoid a => a
mempty)

getRhsFreeVars :: Ghc.HsBind Ghc.GhcRn -> Ghc.UniqSet Ghc.Name
getRhsFreeVars :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> UniqSet Name
getRhsFreeVars = \case
  Ghc.FunBind {[CoreTickish]
MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
LIdP (GhcPass 'Renamed)
XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_tick :: [CoreTickish]
fun_matches :: MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
fun_id :: LIdP (GhcPass 'Renamed)
fun_ext :: XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
..} -> XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext
  Ghc.PatBind {([CoreTickish], [[CoreTickish]])
GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
LPat (GhcPass 'Renamed)
XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_rhs :: GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
pat_lhs :: LPat (GhcPass 'Renamed)
pat_ext :: XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_ticks :: forall idL idR.
HsBindLR idL idR -> ([CoreTickish], [[CoreTickish]])
..} -> XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
pat_ext
  Ghc.PatSynBind XPatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
_ Ghc.PSB {HsPatSynDir (GhcPass 'Renamed)
HsPatSynDetails (GhcPass 'Renamed)
LPat (GhcPass 'Renamed)
LIdP (GhcPass 'Renamed)
XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_dir :: HsPatSynDir (GhcPass 'Renamed)
psb_def :: LPat (GhcPass 'Renamed)
psb_args :: HsPatSynDetails (GhcPass 'Renamed)
psb_id :: LIdP (GhcPass 'Renamed)
psb_ext :: XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_args :: forall idL idR. PatSynBind idL idR -> HsPatSynDetails idR
psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
psb_ext :: forall idL idR. PatSynBind idL idR -> XPSB idL idR
psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
..} -> XPSB (GhcPass 'Renamed) (GhcPass 'Renamed)
psb_ext
  HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
_ -> forall a. Monoid a => a
mempty

--------------------------------------------------------------------------------
-- Do Block
--------------------------------------------------------------------------------

hsDoCase :: Ghc.HsExpr Ghc.GhcRn
         -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))
-- TODO look at the context to determine if it's a recursive do
hsDoCase :: HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsDoCase (Ghc.HsDo XDo (GhcPass 'Renamed)
x HsStmtContext (HsDoRn (GhcPass 'Renamed))
ctx XRec (GhcPass 'Renamed) [GuardLStmt (GhcPass 'Renamed)]
lStmts) = do
  (GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA
     (Stmt
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
stmtsRes, VarSet
_) <- forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for XRec (GhcPass 'Renamed) [GuardLStmt (GhcPass 'Renamed)]
lStmts forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     [LStmt (GhcPass 'Renamed) body]
dealWithStatements
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
Ghc.HsDo XDo (GhcPass 'Renamed)
x HsStmtContext (HsDoRn (GhcPass 'Renamed))
ctx GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA
     (Stmt
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
stmtsRes
hsDoCase HsExpr (GhcPass 'Renamed)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

dealWithStatements
  :: (Data body, Data (Ghc.Stmt Ghc.GhcRn body))
  => [Ghc.LStmt Ghc.GhcRn body]
  -> WriterT VarSet EnvReader [Ghc.LStmt Ghc.GhcRn body]
dealWithStatements :: forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     [LStmt (GhcPass 'Renamed) body]
dealWithStatements [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
dealWithStatements (LStmt (GhcPass 'Renamed) body
lstmt : [LStmt (GhcPass 'Renamed) body]
xs) = do
  (GenLocated
  (Anno (Stmt (GhcPass 'Renamed) body))
  (Stmt (GhcPass 'Renamed) body)
stmtRes, VarSet
names) <- forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall body.
(Data (Stmt (GhcPass 'Renamed) body), Data body) =>
Stmt (GhcPass 'Renamed) body
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     (Stmt (GhcPass 'Renamed) body)
dealWithStmt LStmt (GhcPass 'Renamed) body
lstmt
  (GenLocated
  (Anno (Stmt (GhcPass 'Renamed) body))
  (Stmt (GhcPass 'Renamed) body)
stmtRes forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: * -> *) w w' (m :: * -> *) a b.
(Monad n, Monoid w, Monoid w') =>
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names) (forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     [LStmt (GhcPass 'Renamed) body]
dealWithStatements [LStmt (GhcPass 'Renamed) body]
xs)

dealWithStmt :: (Data (Ghc.Stmt Ghc.GhcRn body), Data body)
             => Ghc.Stmt Ghc.GhcRn body
             -> WriterT VarSet EnvReader (Ghc.Stmt Ghc.GhcRn body)
dealWithStmt :: forall body.
(Data (Stmt (GhcPass 'Renamed) body), Data body) =>
Stmt (GhcPass 'Renamed) body
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     (Stmt (GhcPass 'Renamed) body)
dealWithStmt = \case
  Ghc.BindStmt XBindStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x LPat (GhcPass 'Renamed)
lpat body
body -> do
    let names :: VarSet
names = LPat (GhcPass 'Renamed) -> VarSet
extractVarPats LPat (GhcPass 'Renamed)
lpat
    forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell VarSet
names
    body
bodyRes <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> EnvReader a
recurse body
body
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
Ghc.BindStmt XBindStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x LPat (GhcPass 'Renamed)
lpat body
bodyRes

  Ghc.LetStmt' XLetStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x (Ghc.L SrcSpan
loc HsLocalBinds (GhcPass 'Renamed)
localBinds) -> do
    (HsLocalBinds (GhcPass 'Renamed)
bindsRes, VarSet
names) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ HsLocalBinds (GhcPass 'Renamed)
-> EnvReader (HsLocalBinds (GhcPass 'Renamed), VarSet)
dealWithLocalBinds HsLocalBinds (GhcPass 'Renamed)
localBinds
    forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell VarSet
names
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall body.
XLetStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
-> GenLocated SrcSpan (HsLocalBinds (GhcPass 'Renamed))
-> StmtLR (GhcPass 'Renamed) (GhcPass 'Renamed) body
Ghc.LetStmt' XLetStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x (forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
loc HsLocalBinds (GhcPass 'Renamed)
bindsRes)

  Ghc.ApplicativeStmt XApplicativeStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x [(SyntaxExpr (GhcPass 'Renamed),
  ApplicativeArg (GhcPass 'Renamed))]
pairs Maybe (SyntaxExpr (GhcPass 'Renamed))
mbJoin -> do
    let dealWithAppArg :: ApplicativeArg (GhcPass 'Renamed)
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     (ApplicativeArg (GhcPass 'Renamed))
dealWithAppArg = \case
          a :: ApplicativeArg (GhcPass 'Renamed)
a@Ghc.ApplicativeArgOne{Bool
LPat (GhcPass 'Renamed)
LHsExpr (GhcPass 'Renamed)
XApplicativeArgOne (GhcPass 'Renamed)
app_arg_pattern :: forall idL. ApplicativeArg idL -> LPat idL
arg_expr :: forall idL. ApplicativeArg idL -> LHsExpr idL
is_body_stmt :: forall idL. ApplicativeArg idL -> Bool
xarg_app_arg_one :: forall idL. ApplicativeArg idL -> XApplicativeArgOne idL
is_body_stmt :: Bool
arg_expr :: LHsExpr (GhcPass 'Renamed)
app_arg_pattern :: LPat (GhcPass 'Renamed)
xarg_app_arg_one :: XApplicativeArgOne (GhcPass 'Renamed)
..} -> do
            forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ LPat (GhcPass 'Renamed) -> VarSet
extractVarPats LPat (GhcPass 'Renamed)
app_arg_pattern
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ApplicativeArg (GhcPass 'Renamed)
a
          a :: ApplicativeArg (GhcPass 'Renamed)
a@Ghc.ApplicativeArgMany{[GuardLStmt (GhcPass 'Renamed)]
HsStmtContext (ApplicativeArgStmCtxPass (GhcPass 'Renamed))
HsExpr (GhcPass 'Renamed)
LPat (GhcPass 'Renamed)
XApplicativeArgMany (GhcPass 'Renamed)
app_stmts :: forall idL. ApplicativeArg idL -> [ExprLStmt idL]
bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
final_expr :: forall idL. ApplicativeArg idL -> HsExpr idL
stmt_context :: forall idL.
ApplicativeArg idL -> HsStmtContext (ApplicativeArgStmCtxPass idL)
xarg_app_arg_many :: forall idL. ApplicativeArg idL -> XApplicativeArgMany idL
stmt_context :: HsStmtContext (ApplicativeArgStmCtxPass (GhcPass 'Renamed))
bv_pattern :: LPat (GhcPass 'Renamed)
final_expr :: HsExpr (GhcPass 'Renamed)
app_stmts :: [GuardLStmt (GhcPass 'Renamed)]
xarg_app_arg_many :: XApplicativeArgMany (GhcPass 'Renamed)
..} -> do
            forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ LPat (GhcPass 'Renamed) -> VarSet
extractVarPats LPat (GhcPass 'Renamed)
bv_pattern
            ([GenLocated
   (Anno
      (Stmt
         (GhcPass 'Renamed)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
stmtsRes, VarSet
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     [LStmt (GhcPass 'Renamed) body]
dealWithStatements [GuardLStmt (GhcPass 'Renamed)]
app_stmts
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ApplicativeArg (GhcPass 'Renamed)
a {app_stmts :: [GuardLStmt (GhcPass 'Renamed)]
Ghc.app_stmts = [GenLocated
   (Anno
      (Stmt
         (GhcPass 'Renamed)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
stmtsRes}
    [(SyntaxExprRn, ApplicativeArg (GhcPass 'Renamed))]
pairsRes <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) ApplicativeArg (GhcPass 'Renamed)
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     (ApplicativeArg (GhcPass 'Renamed))
dealWithAppArg [(SyntaxExpr (GhcPass 'Renamed),
  ApplicativeArg (GhcPass 'Renamed))]
pairs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
Ghc.ApplicativeStmt XApplicativeStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x [(SyntaxExprRn, ApplicativeArg (GhcPass 'Renamed))]
pairsRes Maybe (SyntaxExpr (GhcPass 'Renamed))
mbJoin

  Stmt (GhcPass 'Renamed) body
other -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM forall a. Data a => a -> EnvReader a
recurse Stmt (GhcPass 'Renamed) body
other

--------------------------------------------------------------------------------
-- Arrow Notation
--------------------------------------------------------------------------------

hsProcCase :: Ghc.HsExpr Ghc.GhcRn
           -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))
hsProcCase :: HsExpr (GhcPass 'Renamed)
-> EnvReader (Maybe (HsExpr (GhcPass 'Renamed)))
hsProcCase (Ghc.HsProc XProc (GhcPass 'Renamed)
x1 LPat (GhcPass 'Renamed)
lpat LHsCmdTop (GhcPass 'Renamed)
cmdTop) = do
  let inputNames :: VarSet
inputNames = LPat (GhcPass 'Renamed) -> VarSet
extractVarPats LPat (GhcPass 'Renamed)
lpat
  forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    GenLocated SrcSpan (HsCmdTop (GhcPass 'Renamed))
cmdTopRes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for LHsCmdTop (GhcPass 'Renamed)
cmdTop forall a b. (a -> b) -> a -> b
$ \case
      Ghc.HsCmdTop XCmdTop (GhcPass 'Renamed)
x2 LHsCmd (GhcPass 'Renamed)
lcmd -> do
        GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))
cmdRes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for LHsCmd (GhcPass 'Renamed)
lcmd forall a b. (a -> b) -> a -> b
$ \case
          Ghc.HsCmdDo XCmdDo (GhcPass 'Renamed)
x3 XRec (GhcPass 'Renamed) [CmdLStmt (GhcPass 'Renamed)]
lstmts -> do
            (GenLocated
  SrcSpanAnnL
  [GenLocated
     (Anno
        (Stmt
           (GhcPass 'Renamed)
           (GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed)))))
     (Stmt
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))))]
stmtsRes, VarSet
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for XRec (GhcPass 'Renamed) [CmdLStmt (GhcPass 'Renamed)]
lstmts forall a b. (a -> b) -> a -> b
$ \[GenLocated
   SrcSpanAnnA
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))))]
stmts -> do
              forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell VarSet
inputNames
              forall (n :: * -> *) w w' (m :: * -> *) a b.
(Monad n, Monoid w, Monoid w') =>
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
inputNames) forall a b. (a -> b) -> a -> b
$ forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet
     (WriterT Any (ReaderT Env TcM))
     [LStmt (GhcPass 'Renamed) body]
dealWithStatements [GenLocated
   SrcSpanAnnA
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))))]
stmts
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall id. XCmdDo id -> XRec id [CmdLStmt id] -> HsCmd id
Ghc.HsCmdDo XCmdDo (GhcPass 'Renamed)
x3 GenLocated
  SrcSpanAnnL
  [GenLocated
     (Anno
        (Stmt
           (GhcPass 'Renamed)
           (GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed)))))
     (Stmt
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))))]
stmtsRes

          HsCmd (GhcPass 'Renamed)
_ -> forall (f :: * -> *) a. Alternative f => f a
empty -- TODO what other cases should be handled?

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
Ghc.HsCmdTop XCmdTop (GhcPass 'Renamed)
x2 GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))
cmdRes
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
Ghc.HsProc XProc (GhcPass 'Renamed)
x1 LPat (GhcPass 'Renamed)
lpat GenLocated SrcSpan (HsCmdTop (GhcPass 'Renamed))
cmdTopRes
hsProcCase HsExpr (GhcPass 'Renamed)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Env
--------------------------------------------------------------------------------

-- The writer is for tracking if an inner expression contains the target name
type EnvReader = WriterT Any (ReaderT Env Ghc.TcM)

type VarSet = M.Map Ghc.LexicalFastString Ghc.Name

data Env = MkEnv
  { Env -> VarSet
varSet :: !VarSet
  , Env -> Name
captureVarsName :: !Ghc.Name
  , Env -> Name
showLevName :: !Ghc.Name
  , Env -> Name
fromListName :: !Ghc.Name
  , Env -> Name
breakpointName :: !Ghc.Name
  , Env -> Name
queryVarsName :: !Ghc.Name
  , Env -> Name
breakpointMName :: !Ghc.Name
  , Env -> Name
queryVarsMName :: !Ghc.Name
  , Env -> Name
breakpointIOName :: !Ghc.Name
  , Env -> Name
queryVarsIOName :: !Ghc.Name
  , Env -> Name
printAndWaitName :: !Ghc.Name
  , Env -> Name
printAndWaitMName :: !Ghc.Name
  , Env -> Name
printAndWaitIOName :: !Ghc.Name
  , Env -> Name
runPromptIOName :: !Ghc.Name
  , Env -> Name
runPromptName :: !Ghc.Name
  , Env -> Name
runPromptMName :: !Ghc.Name
  , Env -> Name
getSrcLocName :: !Ghc.Name
  , Env -> Name
excludeVarsName :: !Ghc.Name
  }

overVarSet :: (VarSet -> VarSet) -> Env -> Env
overVarSet :: (VarSet -> VarSet) -> Env -> Env
overVarSet VarSet -> VarSet
f Env
env = Env
env { varSet :: VarSet
varSet = VarSet -> VarSet
f forall a b. (a -> b) -> a -> b
$ Env -> VarSet
varSet Env
env }

getOccNameFS :: Ghc.Name -> Ghc.LexicalFastString
getOccNameFS :: Name -> LexicalFastString
getOccNameFS = FastString -> LexicalFastString
Ghc.mkLexicalFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> FastString
Ghc.occNameFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> OccName
Ghc.getOccName

mkVarSet :: [Ghc.Name] -> VarSet
mkVarSet :: [Name] -> VarSet
mkVarSet [Name]
names = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ (Name -> LexicalFastString
getOccNameFS forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names

addScopedVars :: VarSet -> EnvReader a -> EnvReader a
addScopedVars :: forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names = forall (n :: * -> *) w w' (m :: * -> *) a b.
(Monad n, Monoid w, Monoid w') =>
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((VarSet -> VarSet) -> Env -> Env
overVarSet (VarSet
names forall a. Semigroup a => a -> a -> a
<>))

--------------------------------------------------------------------------------
-- Vendored from GHC
--------------------------------------------------------------------------------

depAnalBinds :: [(Ghc.LHsBind Ghc.GhcRn, [Ghc.Name], Ghc.UniqSet Ghc.Name)]
             -> [(Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn)]
depAnalBinds :: [(LHsBind (GhcPass 'Renamed), [Name], UniqSet Name)]
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
depAnalBinds [(LHsBind (GhcPass 'Renamed), [Name], UniqSet Name)]
binds_w_dus
  = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. SCC (a, b, c) -> (RecFlag, Bag a)
get_binds [SCC
   (GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
    [Name], UniqSet Name)]
sccs
  where
    sccs :: [SCC
   (GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)),
    [Name], UniqSet Name)]
sccs = forall node.
(node -> [Name]) -> (node -> [Name]) -> [node] -> [SCC node]
Ghc.depAnal
             (\(GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_, [Name]
defs, UniqSet Name
_) -> [Name]
defs)
             (\(GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_, [Name]
_, UniqSet Name
uses) -> forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet UniqSet Name
uses)
             [(LHsBind (GhcPass 'Renamed), [Name], UniqSet Name)]
binds_w_dus

    get_binds :: SCC (a, b, c) -> (RecFlag, Bag a)
get_binds (Graph.AcyclicSCC (a
bind, b
_, c
_)) =
      (RecFlag
Ghc.NonRecursive, forall a. a -> Bag a
Ghc.unitBag a
bind)
    get_binds (Graph.CyclicSCC  [(a, b, c)]
binds_w_dus') =
      (RecFlag
Ghc.Recursive, forall a. [a] -> Bag a
Ghc.listToBag [a
b | (a
b,b
_,c
_) <- [(a, b, c)]
binds_w_dus'])