{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
module Debug.Breakpoint
(
plugin
, breakpoint
, breakpointM
, breakpointIO
, queryVars
, queryVarsM
, queryVarsIO
, excludeVars
, captureVars
, showLev
, fromAscList
, printAndWait
, printAndWaitM
, printAndWaitIO
, runPrompt
, runPromptM
, runPromptIO
, getSrcLoc
) where
import Control.Applicative ((<|>), empty)
import Control.Arrow ((&&&))
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Writer.CPS
import Data.Char (isSpace)
import Data.Data hiding (IntRep, FloatRep)
import Data.Either
import Data.Foldable
import Data.Functor
import qualified Data.Graph as Graph
import qualified Data.List as L
import qualified Data.Map.Lazy as M
import Data.Maybe
import Data.Monoid (Any(..))
import qualified Data.Text.Lazy as T
import Data.Traversable (for)
import Debug.Trace (trace, traceIO, traceM)
import qualified GHC.Exts as Exts
import GHC.Int
#if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Tc.Plugin as Plugin
#else
import qualified TcPluginM as Plugin
#endif
import GHC.Word
import qualified System.Console.ANSI as ANSI
import qualified System.Console.Haskeline as HL
import System.Environment (lookupEnv)
import System.IO (stdout)
import System.IO.Unsafe (unsafePerformIO)
import qualified Text.Pretty.Simple as PS
import qualified Text.Pretty.Simple.Internal.Color as PS
import qualified Debug.Breakpoint.GhcFacade as Ghc
import qualified Debug.Breakpoint.TimerManager as TM
captureVars :: M.Map String String
captureVars :: Map String String
captureVars = forall a. Monoid a => a
mempty
fromAscList :: Ord k => [(k, v)] -> M.Map k v
fromAscList :: forall k v. Ord k => [(k, v)] -> Map k v
fromAscList = forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList
printAndWait :: String -> M.Map String String -> a -> a
printAndWait :: forall a. String -> Map String String -> a -> a
printAndWait String
srcLoc Map String String
vars a
x =
forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> Map String String -> m ()
printAndWaitIO String
srcLoc Map String String
vars forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
{-# NOINLINE printAndWait #-}
printAndWaitM :: Applicative m => String -> M.Map String String -> m ()
printAndWaitM :: forall (m :: * -> *).
Applicative m =>
String -> Map String String -> m ()
printAndWaitM String
srcLoc Map String String
vars = forall a. String -> Map String String -> a -> a
printAndWait String
srcLoc Map String String
vars forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
printAndWaitIO :: MonadIO m => String -> M.Map String String -> m ()
printAndWaitIO :: forall (m :: * -> *).
MonadIO m =>
String -> Map String String -> m ()
printAndWaitIO String
srcLoc Map String String
vars = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Bool
useColor <- Handle -> IO Bool
ANSI.hSupportsANSIColor Handle
stdout
let ?useColor = Bool
useColor
Bool
prettyPrint <- IO Bool
usePrettyPrinting
let ?prettyPrint = Bool
prettyPrint
forall a. IO a -> IO a
TM.suspendTimeouts forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
traceIO forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n"
[ (?useColor::Bool) => String -> String -> String
color String
red String
"### Breakpoint Hit ###"
, (?useColor::Bool) => String -> String -> String
color String
grey String
"(" forall a. Semigroup a => a -> a -> a
<> String
srcLoc forall a. Semigroup a => a -> a -> a
<> String
")"
, (?useColor::Bool, ?prettyPrint::Bool) =>
Map String String -> String
printVars Map String String
vars
, (?useColor::Bool) => String -> String -> String
color String
green String
"Press enter to continue"
]
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Int
blockOnInput
runPrompt :: String -> M.Map String String -> a -> a
runPrompt :: forall a. String -> Map String String -> a -> a
runPrompt String
srcLoc Map String String
vars a
x =
forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
String -> Map String String -> m ()
runPromptIO String
srcLoc Map String String
vars forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
{-# NOINLINE runPrompt #-}
runPromptM :: Applicative m => String -> M.Map String String -> m ()
runPromptM :: forall (m :: * -> *).
Applicative m =>
String -> Map String String -> m ()
runPromptM String
srcLoc Map String String
vars = forall a. String -> Map String String -> a -> a
runPrompt String
srcLoc Map String String
vars forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
runPromptIO :: forall m. MonadIO m => String -> M.Map String String -> m ()
runPromptIO :: forall (m :: * -> *).
MonadIO m =>
String -> Map String String -> m ()
runPromptIO String
srcLoc Map String String
vars = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Behavior -> Settings m -> InputT m a -> m a
HL.runInputTBehavior Behavior
HL.defaultBehavior Settings IO
settings forall a b. (a -> b) -> a -> b
$ do
Bool
useColor <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
ANSI.hSupportsANSIColor Handle
stdout
let ?useColor = Bool
useColor
Bool
prettyPrint <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
usePrettyPrinting
let ?prettyPrint = Bool
prettyPrint
let printVar :: String -> String -> InputT m ()
printVar String
var String
val =
forall (m :: * -> *). MonadIO m => String -> InputT m ()
HL.outputStrLn forall a b. (a -> b) -> a -> b
$ (?useColor::Bool) => String -> String -> String
color String
cyan (String
var forall a. [a] -> [a] -> [a]
++ String
" =\n") forall a. [a] -> [a] -> [a]
++ (?prettyPrint::Bool) => String -> String
prettify String
val
inputLoop :: InputT IO ()
inputLoop = do
Maybe String
mInp <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
HL.getInputLine forall a b. (a -> b) -> a -> b
$ (?useColor::Bool) => String -> String -> String
color String
green String
"Enter variable name: "
case Maybe String
mInp of
Just (forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace -> String
inp)
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
inp) -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {m :: * -> *}.
(MonadIO m, ?useColor::Bool, ?prettyPrint::Bool) =>
String -> String -> InputT m ()
printVar String
inp) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
inp Map String String
vars
InputT IO ()
inputLoop
Maybe String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
HL.outputStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
[ (?useColor::Bool) => String -> String -> String
color String
red String
"### Breakpoint Hit ###"
, (?useColor::Bool) => String -> String -> String
color String
grey forall a b. (a -> b) -> a -> b
$ String
"(" forall a. Semigroup a => a -> a -> a
<> String
srcLoc forall a. Semigroup a => a -> a -> a
<> String
")"
] forall a. [a] -> [a] -> [a]
++ ((?useColor::Bool) => String -> String -> String
color String
cyan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
varNames)
InputT IO ()
inputLoop
where
settings :: Settings IO
settings = forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
HL.setComplete CompletionFunc IO
completion forall (m :: * -> *). MonadIO m => Settings m
HL.defaultSettings
completion :: CompletionFunc IO
completion = forall (m :: * -> *).
Monad m =>
Maybe Char
-> (Char -> Bool) -> (String -> m [Completion]) -> CompletionFunc m
HL.completeWord' forall a. Maybe a
Nothing Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ \String
str ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Completion
HL.simpleCompletion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (String
str forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf`) [String]
varNames
varNames :: [String]
varNames = forall k a. Map k a -> [k]
M.keys Map String String
vars
usePrettyPrinting :: IO Bool
usePrettyPrinting :: IO Bool
usePrettyPrinting = forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"NO_PRETTY_PRINT"
color :: (?useColor :: Bool) => String -> String -> String
color :: (?useColor::Bool) => String -> String -> String
color String
c String
s =
if ?useColor::Bool
?useColor
then String
"\ESC[" forall a. Semigroup a => a -> a -> a
<> String
c forall a. Semigroup a => a -> a -> a
<> String
"m\STX" forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"\ESC[m\STX"
else String
s
red, green, grey, cyan :: String
red :: String
red = String
"31"
green :: String
green = String
"32"
grey :: String
grey = String
"37"
cyan :: String
cyan = String
"36"
printVars :: (?useColor :: Bool, ?prettyPrint :: Bool)
=> M.Map String String -> String
printVars :: (?useColor::Bool, ?prettyPrint::Bool) =>
Map String String -> String
printVars Map String String
vars =
let eqSign :: String
eqSign | ?prettyPrint::Bool
?prettyPrint = String
" =\n"
| Bool
otherwise = String
" = "
mkLine :: (String, String) -> String
mkLine (String
k, String
v) = (?useColor::Bool) => String -> String -> String
color String
cyan (String
k forall a. Semigroup a => a -> a -> a
<> String
eqSign) forall a. Semigroup a => a -> a -> a
<> (?prettyPrint::Bool) => String -> String
prettify String
v
in [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
L.intersperse String
"" forall a b. (a -> b) -> a -> b
$ (?useColor::Bool, ?prettyPrint::Bool) => (String, String) -> String
mkLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map String String
vars
prettify :: (?prettyPrint :: Bool) => String -> String
prettify :: (?prettyPrint::Bool) => String -> String
prettify =
if ?prettyPrint::Bool
?prettyPrint
then Text -> String
T.unpack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> String -> Text
PS.pStringOpt
OutputOptions
PS.defaultOutputOptionsDarkBg
{ outputOptionsInitialIndent :: Int
PS.outputOptionsInitialIndent = Int
2
, outputOptionsIndentAmount :: Int
PS.outputOptionsIndentAmount = Int
2
, outputOptionsColorOptions :: Maybe ColorOptions
PS.outputOptionsColorOptions = forall a. a -> Maybe a
Just PS.ColorOptions
{ colorQuote :: Style
PS.colorQuote = Style
PS.colorNull
, colorString :: Style
PS.colorString = Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Blue
, colorError :: Style
PS.colorError = Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Red
, colorNum :: Style
PS.colorNum = Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Green
, colorRainbowParens :: [Style]
PS.colorRainbowParens = [Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Cyan]
}
}
else forall a. a -> a
id
inactivePluginStr :: String
inactivePluginStr :: String
inactivePluginStr =
String
"Cannot set breakpoint: the Debug.Trace plugin is not active"
breakpoint :: a -> a
breakpoint :: forall a. a -> a
breakpoint = forall a. String -> a -> a
trace String
inactivePluginStr
queryVars :: a -> a
queryVars :: forall a. a -> a
queryVars = forall a. String -> a -> a
trace String
inactivePluginStr
queryVarsM :: Applicative m => m ()
queryVarsM :: forall (m :: * -> *). Applicative m => m ()
queryVarsM = forall (f :: * -> *). Applicative f => String -> f ()
traceM String
inactivePluginStr
queryVarsIO :: MonadIO m => m ()
queryVarsIO :: forall (m :: * -> *). MonadIO m => m ()
queryVarsIO =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
traceIO String
inactivePluginStr)
breakpointM :: Applicative m => m ()
breakpointM :: forall (m :: * -> *). Applicative m => m ()
breakpointM = forall (f :: * -> *). Applicative f => String -> f ()
traceM String
inactivePluginStr
breakpointIO :: MonadIO m => m ()
breakpointIO :: forall (m :: * -> *). MonadIO m => m ()
breakpointIO =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
traceIO String
inactivePluginStr)
getSrcLoc :: String
getSrcLoc :: String
getSrcLoc = String
""
#if MIN_VERSION_ghc(9,2,0)
foreign import ccall unsafe "stdio.h getchar" blockOnInput :: IO Int
#else
blockOnInput :: IO Int
blockOnInput = 1 <$ getLine
#endif
excludeVars :: [String] -> a -> a
excludeVars :: forall a. [String] -> a -> a
excludeVars [String]
_ = forall a. a -> a
id
plugin :: Ghc.Plugin
plugin :: Plugin
plugin = Plugin
Ghc.defaultPlugin
{ pluginRecompile :: [String] -> IO PluginRecompile
Ghc.pluginRecompile = [String] -> IO PluginRecompile
Ghc.purePlugin
, renamedResultAction :: [String]
-> TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
Ghc.renamedResultAction = forall a b. a -> b -> a
const TcGblEnv
-> HsGroup (GhcPass 'Renamed)
-> TcM (TcGblEnv, HsGroup (GhcPass 'Renamed))
renameAction
, tcPlugin :: TcPlugin
Ghc.tcPlugin = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TcPlugin
tcPlugin
}
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")
let (HsGroup (GhcPass 'Renamed)
group', Any
_) =
forall r a. Reader r a -> r -> a
runReader (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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env)) 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 (Reader Env) (Maybe a)
f') -> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ a -> WriterT Any (Reader Env) (Maybe a)
f' a
a
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 ann. SrcSpanAnn' ann -> SrcSpan
Ghc.locA' SrcSpanAnnN
loc
captureVarsExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr =
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)
]
#if MIN_VERSION_ghc(9,2,0)
NoExtField
Ghc.NoExtField
#endif
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)
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
varSet
bpExpr :: LHsExpr (GhcPass 'Renamed)
bpExpr =
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)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr
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)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr
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)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr
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)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr
queryVarsExpr :: LHsExpr (GhcPass 'Renamed)
queryVarsExpr =
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)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr
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)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr
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 a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
captureVarsExpr)
| 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 (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)
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 (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)
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
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 p -> Maybe LexicalFastString'
extractVarName (Ghc.HsLit XLitE p
_ (Ghc.HsString XHsString p
_ FastString
fs)) =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FastString -> LexicalFastString'
Ghc.mkLexicalFastString FastString
fs
extractVarName HsExpr p
_ = forall a. Maybe a
Nothing
varsToExclude :: [LexicalFastString']
varsToExclude =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {p}. HsExpr p -> 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
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))
.. }
#if !MIN_VERSION_ghc(9,0,0)
matchCase _ = pure Nothing
#endif
extractVarPats :: Ghc.LPat Ghc.GhcRn -> VarSet
= [Name] -> VarSet
mkVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat (GhcPass 'Renamed) -> [Name]
Ghc.collectPatBinders'
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
#if MIN_VERSION_ghc(9,2,0)
HsLocalBinds (GhcPass 'Renamed)
grhssLocalBinds
#else
(Ghc.unLoc grhssLocalBinds)
#endif
[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
#if MIN_VERSION_ghc(9,2,0)
, grhssLocalBinds :: HsLocalBinds (GhcPass 'Renamed)
grhssLocalBinds = HsLocalBinds (GhcPass 'Renamed)
localBindsRes
#else
, grhssLocalBinds = localBindsRes <$ grhssLocalBinds
#endif
, XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhssExt :: XCGRHSs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
grhssExt :: XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
..
}
#if !MIN_VERSION_ghc(9,0,0)
grhssCase _ = pure Nothing
#endif
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
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)
.. }
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 (Reader Env)) [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
#if !MIN_VERSION_ghc(9,0,0)
grhsCase _ = pure Nothing
#endif
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)
else do
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)
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
hsDoCase :: Ghc.HsExpr Ghc.GhcRn
-> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))
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 (Reader Env)) [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 (Reader Env)) [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 (Reader Env)) (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 (Reader Env)) [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 (Reader Env)) (Stmt (GhcPass 'Renamed) body)
dealWithStmt = \case
Ghc.BindStmt' XBindStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x LPat (GhcPass 'Renamed)
lpat body
body SyntaxExpr (GhcPass 'Renamed)
bindExpr SyntaxExpr (GhcPass 'Renamed)
failExpr -> 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 body.
XBindStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
-> LPat (GhcPass 'Renamed)
-> body
-> SyntaxExpr (GhcPass 'Renamed)
-> SyntaxExpr (GhcPass 'Renamed)
-> Stmt (GhcPass 'Renamed) body
Ghc.BindStmt' XBindStmt (GhcPass 'Renamed) (GhcPass 'Renamed) body
x LPat (GhcPass 'Renamed)
lpat body
bodyRes SyntaxExpr (GhcPass 'Renamed)
bindExpr SyntaxExpr (GhcPass 'Renamed)
failExpr
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 (Reader Env))
(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 (Reader Env)) [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}
#if !MIN_VERSION_ghc(9,0,0)
a -> lift $ gmapM recurse a
#endif
[(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 (Reader Env))
(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
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 (Reader Env)) [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
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
#if !MIN_VERSION_ghc(9,0,0)
_ -> empty
#endif
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
type EnvReader = WriterT Any (Reader Env)
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 v. Ord k => [(k, v)] -> Map k v
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
<>))
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'])
data TcPluginNames =
MkTcPluginNames
{ TcPluginNames -> Name
showLevClassName :: !Ghc.Name
, TcPluginNames -> Class
showClass :: !Ghc.Class
, TcPluginNames -> Class
succeedClass :: !Ghc.Class
, TcPluginNames -> TyCon
showWrapperTyCon :: !Ghc.TyCon
}
tcPlugin :: Ghc.TcPlugin
tcPlugin :: TcPlugin
tcPlugin = Ghc.TcPlugin
{ tcPluginInit :: TcPluginM TcPluginNames
Ghc.tcPluginInit = TcPluginM TcPluginNames
initTcPlugin
, tcPluginSolve :: TcPluginNames -> TcPluginSolver
Ghc.tcPluginSolve = TcPluginNames -> TcPluginSolver
solver
, tcPluginStop :: TcPluginNames -> TcPluginM ()
Ghc.tcPluginStop = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if MIN_VERSION_ghc(9,4,0)
, Ghc.tcPluginRewrite = mempty
#endif
}
initTcPlugin :: Ghc.TcPluginM TcPluginNames
initTcPlugin :: TcPluginM TcPluginNames
initTcPlugin = do
Ghc.Found ModLocation
_ Module
breakpointMod <-
ModuleName -> TcPluginM FindResult
Ghc.findImportedModule' (String -> ModuleName
Ghc.mkModuleName String
"Debug.Breakpoint")
Ghc.Found ModLocation
_ Module
showMod <-
ModuleName -> TcPluginM FindResult
Ghc.findImportedModule' (String -> ModuleName
Ghc.mkModuleName String
"GHC.Show")
Name
showLevClassName <- Module -> OccName -> TcPluginM Name
Plugin.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkClsOcc String
"ShowLev")
Class
showClass <- Name -> TcPluginM Class
Plugin.tcLookupClass forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
Plugin.lookupOrig Module
showMod (String -> OccName
Ghc.mkClsOcc String
"Show")
Class
succeedClass <- Name -> TcPluginM Class
Plugin.tcLookupClass forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
Plugin.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkClsOcc String
"Succeed")
TyCon
showWrapperTyCon <- Name -> TcPluginM TyCon
Plugin.tcLookupTyCon forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> OccName -> TcPluginM Name
Plugin.lookupOrig Module
breakpointMod (String -> OccName
Ghc.mkClsOcc String
"ShowWrapper")
forall (f :: * -> *) a. Applicative f => a -> f a
pure MkTcPluginNames{Class
TyCon
Name
showWrapperTyCon :: TyCon
succeedClass :: Class
showClass :: Class
showLevClassName :: Name
showWrapperTyCon :: TyCon
succeedClass :: Class
showClass :: Class
showLevClassName :: Name
..}
findShowLevWanted
:: TcPluginNames
-> Ghc.Ct
-> Maybe (Either (Ghc.Type, Ghc.Ct) (Ghc.Type, Ghc.Ct))
findShowLevWanted :: TcPluginNames -> Ct -> Maybe (Either (Type, Ct) (Type, Ct))
findShowLevWanted TcPluginNames
names Ct
ct
| Ghc.CDictCan{Bool
[Type]
CtEvidence
Class
cc_class :: Ct -> Class
cc_ev :: Ct -> CtEvidence
cc_pend_sc :: Ct -> Bool
cc_tyargs :: Ct -> [Type]
cc_pend_sc :: Bool
cc_tyargs :: [Type]
cc_class :: Class
cc_ev :: CtEvidence
..} <- Ct
ct
, TcPluginNames -> Name
showLevClassName TcPluginNames
names forall a. Eq a => a -> a -> Bool
== forall a. NamedThing a => a -> Name
Ghc.getName Class
cc_class
, [Ghc.TyConApp TyCon
tyCon [], Type
arg2] <- [Type]
cc_tyargs
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if forall a. NamedThing a => a -> Name
Ghc.getName TyCon
tyCon forall a. Eq a => a -> a -> Bool
== Name
Ghc.liftedRepName
then forall a b. b -> Either a b
Right (Type
arg2, Ct
ct)
else forall a b. a -> Either a b
Left (Type
arg2, Ct
ct)
| Bool
otherwise = forall a. Maybe a
Nothing
solver :: TcPluginNames -> Ghc.TcPluginSolver
solver :: TcPluginNames -> TcPluginSolver
solver TcPluginNames
names [Ct]
_given [Ct]
_derived [Ct]
wanted = do
InstEnvs
instEnvs <- TcPluginM InstEnvs
Plugin.getInstEnvs
[Maybe (EvTerm, Ct)]
solved <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (TcPluginNames -> Ct -> Maybe (Either (Type, Ct) (Type, Ct))
findShowLevWanted TcPluginNames
names forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [Ct]
wanted) forall a b. (a -> b) -> a -> b
$ \case
Left (Type
ty, Ct
ct) -> do
EvTerm
unshowableDict <- forall a. TcM a -> TcPluginM a
Ghc.unsafeTcPluginTcM forall a b. (a -> b) -> a -> b
$ Type -> TcM EvTerm
buildUnshowableDict Type
ty
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (EvTerm
unshowableDict, Ct
ct)
Right (Type
ty, Ct
ct) -> do
Maybe EvTerm
mShowDict <- TcPluginNames -> Class -> [Type] -> TcPluginM (Maybe EvTerm)
buildDict TcPluginNames
names (TcPluginNames -> Class
showClass TcPluginNames
names) [Type
ty]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe EvTerm
mShowDict forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \EvTerm
showDict ->
let (ClsInst
succInst, [Type]
_) = forall b a. b -> Either a b -> b
fromRight (forall a. HasCallStack => String -> a
error String
"impossible: no Succeed instance") forall a b. (a -> b) -> a -> b
$
InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type])
Ghc.lookupUniqueInstEnv InstEnvs
instEnvs (TcPluginNames -> Class
succeedClass TcPluginNames
names) [Type
ty]
in (ClsInst -> Type -> EvExpr -> EvTerm
liftDict ClsInst
succInst Type
ty (EvTerm -> EvExpr
getEvExprFromDict EvTerm
showDict), Ct
ct)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk (forall a. [Maybe a] -> [a]
catMaybes [Maybe (EvTerm, Ct)]
solved) []
buildDict
:: TcPluginNames
-> Ghc.Class
-> [Ghc.Type]
-> Ghc.TcPluginM (Maybe Ghc.EvTerm)
buildDict :: TcPluginNames -> Class -> [Type] -> TcPluginM (Maybe EvTerm)
buildDict TcPluginNames
names Class
cls [Type]
tys = do
InstEnvs
instEnvs <- TcPluginM InstEnvs
Plugin.getInstEnvs
case InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type])
Ghc.lookupUniqueInstEnv InstEnvs
instEnvs Class
cls [Type]
tys of
Right (ClsInst
clsInst, [Type]
_) -> do
let dfun :: TyVar
dfun = ClsInst -> TyVar
Ghc.is_dfun ClsInst
clsInst
([TyVar]
vars, [Type]
subclasses, Type
inst) = Type -> ([TyVar], [Type], Type)
Ghc.tcSplitSigmaTy forall a b. (a -> b) -> a -> b
$ TyVar -> Type
Ghc.idType TyVar
dfun
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
subclasses
then 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
$ TyVar -> [Type] -> [EvExpr] -> EvTerm
Ghc.evDFunApp TyVar
dfun [] []
else do
let tyVarMap :: Map TyVar Type
tyVarMap = Type -> [Type] -> Map TyVar Type
mkTyVarMapping Type
inst [Type]
tys
Maybe [EvTerm]
mSolvedSubClassDicts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence 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 [Type]
subclasses forall a b. (a -> b) -> a -> b
$ \Type
subclass -> do
let (Class
subCls, [Type]
subTys) = Type -> (Class, [Type])
Ghc.tcSplitDFunHead Type
subclass
subTys' :: [Type]
subTys' = Map TyVar Type -> [Type] -> [Type]
instantiateVars Map TyVar Type
tyVarMap [Type]
subTys
TcPluginNames -> Class -> [Type] -> TcPluginM (Maybe EvTerm)
buildDict TcPluginNames
names Class
subCls [Type]
subTys'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
[Type]
vars' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map TyVar Type
tyVarMap forall k a. Ord k => Map k a -> k -> Maybe a
M.!?) [TyVar]
vars
TyVar -> [Type] -> [EvExpr] -> EvTerm
Ghc.evDFunApp TyVar
dfun [Type]
vars' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map EvTerm -> EvExpr
getEvExprFromDict
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [EvTerm]
mSolvedSubClassDicts
Left SDoc
_
| Class
cls forall a. Eq a => a -> a -> Bool
== TcPluginNames -> Class
showClass TcPluginNames
names
, [Type
ty] <- [Type]
tys -> do
EvTerm
unshowableDict <- forall a. TcM a -> TcPluginM a
Ghc.unsafeTcPluginTcM forall a b. (a -> b) -> a -> b
$ Type -> TcM EvTerm
buildUnshowableDict Type
ty
let (ClsInst
inst, [Type]
_) = forall b a. b -> Either a b -> b
fromRight (forall a. HasCallStack => String -> a
error String
"impossible: no Show instance for ShowWrapper") forall a b. (a -> b) -> a -> b
$
InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type])
Ghc.lookupUniqueInstEnv
InstEnvs
instEnvs
(TcPluginNames -> Class
showClass TcPluginNames
names)
[TyCon -> [Type] -> Type
Ghc.mkTyConApp (TcPluginNames -> TyCon
showWrapperTyCon TcPluginNames
names) [Type
ty]]
liftedDict :: EvTerm
liftedDict =
ClsInst -> Type -> EvExpr -> EvTerm
liftDict ClsInst
inst Type
ty (EvTerm -> EvExpr
getEvExprFromDict EvTerm
unshowableDict)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just EvTerm
liftedDict
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
getEvExprFromDict :: Ghc.EvTerm -> Ghc.EvExpr
getEvExprFromDict :: EvTerm -> EvExpr
getEvExprFromDict = \case
Ghc.EvExpr EvExpr
expr -> EvExpr
expr
EvTerm
_ -> forall a. HasCallStack => String -> a
error String
"invalid argument to getEvExprFromDict"
mkTyVarMapping
:: Ghc.Type
-> [Ghc.Type]
-> M.Map Ghc.TyVar Ghc.Type
mkTyVarMapping :: Type -> [Type] -> Map TyVar Type
mkTyVarMapping Type
wanted [Type]
tys =
let wantedHead :: [Type]
wantedHead = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Type -> (Type, [Type])
Ghc.splitAppTys Type
wanted
wantedTyVars :: [Type]
wantedTyVars = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Type, [Type])
Ghc.splitAppTys) [Type]
wantedHead
concreteTys :: [Type]
concreteTys = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Type, [Type])
Ghc.splitAppTys) [Type]
tys
in forall k v. Ord k => [(k, v)] -> Map k v
M.fromList forall a b. (a -> b) -> a -> b
$ do
(Type
a, Type
b) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
wantedTyVars [Type]
concreteTys
Just TyVar
tyVar <- [Type -> Maybe TyVar
Ghc.getTyVar_maybe Type
a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVar
tyVar, Type
b)
instantiateVars :: M.Map Ghc.TyVar Ghc.Type -> [Ghc.Type] -> [Ghc.Type]
instantiateVars :: Map TyVar Type -> [Type] -> [Type]
instantiateVars Map TyVar Type
tyVarMap [Type]
tys = Type -> Type
replace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tys
where
replace :: Type -> Type
replace Type
arg = forall a. a -> Maybe a -> a
fromMaybe Type
arg forall a b. (a -> b) -> a -> b
$ do
TyVar
tyVar <- Type -> Maybe TyVar
Ghc.getTyVar_maybe Type
arg
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TyVar
tyVar Map TyVar Type
tyVarMap
buildUnshowableDict :: Ghc.Type -> Ghc.TcM Ghc.EvTerm
buildUnshowableDict :: Type -> TcM EvTerm
buildUnshowableDict Type
ty = do
let tyString :: String
tyString = SDoc -> String
Ghc.showSDocOneLine' forall a b. (a -> b) -> a -> b
$ Type -> SDoc
Ghc.pprTypeForUser' Type
ty
EvExpr
str <- forall (m :: * -> *). MonadThings m => String -> m EvExpr
Ghc.mkStringExpr forall a b. (a -> b) -> a -> b
$ String
"<" forall a. Semigroup a => a -> a -> a
<> String
tyString forall a. Semigroup a => a -> a -> a
<> String
">"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvExpr -> EvTerm
Ghc.EvExpr forall a b. (a -> b) -> a -> b
$
[TyVar] -> EvExpr -> EvExpr
Ghc.mkCoreLams [Type -> TyVar
Ghc.mkWildValBinder' Type
ty] EvExpr
str
liftDict :: Ghc.ClsInst -> Ghc.Type -> Ghc.EvExpr -> Ghc.EvTerm
liftDict :: ClsInst -> Type -> EvExpr -> EvTerm
liftDict ClsInst
succ_inst Type
ty EvExpr
dict = TyVar -> [Type] -> [EvExpr] -> EvTerm
Ghc.evDFunApp (ClsInst -> TyVar
Ghc.is_dfun ClsInst
succ_inst) [Type
ty] [EvExpr
dict]
class ShowLev (rep :: Exts.RuntimeRep) (a :: Exts.TYPE rep) where
showLev :: a -> String
instance ShowLev 'Exts.IntRep Exts.Int# where
showLev :: Int# -> String
showLev Int#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int# -> Int
I# Int#
i
#if MIN_VERSION_base(4,16,0)
instance ShowLev 'Exts.Int8Rep Exts.Int8# where
showLev :: Int8# -> String
showLev Int8#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int8# -> Int8
I8# Int8#
i
instance ShowLev 'Exts.Int16Rep Exts.Int16# where
showLev :: Int16# -> String
showLev Int16#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int16# -> Int16
I16# Int16#
i
instance ShowLev 'Exts.Int32Rep Exts.Int32# where
showLev :: Int32# -> String
showLev Int32#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int32# -> Int32
I32# Int32#
i
#endif
#if MIN_VERSION_base(4,17,0)
instance ShowLev 'Exts.Int64Rep Exts.Int64# where
showLev i = show $ I64# i
#endif
instance ShowLev 'Exts.WordRep Exts.Word# where
showLev :: Word# -> String
showLev Word#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word# -> Word
W# Word#
w
#if MIN_VERSION_base(4,16,0)
instance ShowLev 'Exts.Word8Rep Exts.Word8# where
showLev :: Word8# -> String
showLev Word8#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word8# -> Word8
W8# Word8#
w
instance ShowLev 'Exts.Word16Rep Exts.Word16# where
showLev :: Word16# -> String
showLev Word16#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word16# -> Word16
W16# Word16#
w
instance ShowLev 'Exts.Word32Rep Exts.Word32# where
showLev :: Word32# -> String
showLev Word32#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word32# -> Word32
W32# Word32#
w
#endif
#if MIN_VERSION_base(4,17,0)
instance ShowLev 'Exts.Word64Rep Exts.Word64# where
showLev w = show $ W64# w
#endif
instance ShowLev 'Exts.FloatRep Exts.Float# where
showLev :: Float# -> String
showLev Float#
f = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Float# -> Float
Exts.F# Float#
f
instance ShowLev 'Exts.DoubleRep Exts.Double# where
showLev :: Double# -> String
showLev Double#
d = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double# -> Double
Exts.D# Double#
d
newtype ShowWrapper a = MkShowWrapper a
instance ShowLev Exts.LiftedRep a => Show (ShowWrapper a) where
show :: ShowWrapper a -> String
show (MkShowWrapper a
a) = forall a. ShowLev LiftedRep a => a -> String
showLev a
a
class Succeed a where
_succeed :: a -> String
instance Show a => Succeed a where
_succeed :: a -> String
_succeed = forall a. Show a => a -> String
show