{-# 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
    plugin
    -- * API
  , breakpoint
  , breakpointM
  , breakpointIO
  , queryVars
  , queryVarsM
  , queryVarsIO
  , excludeVars
    -- * Internals
  , 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

--------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------

-- | Constructs a lazy 'Map' from the names of all visible variables at the call
-- site to a string representation of their value. Does not include any variables
-- whose definitions contain it. Be careful not to assign multiple variables to
-- `captureVars` in the same scope as this will result in an infinite recursion.
captureVars :: M.Map String String
captureVars :: Map String String
captureVars = forall a. Monoid a => a
mempty

-- re-exported to avoid requiring the client to depend on the containers package
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

-- TODO don't apply parsing to things inside angle brackets
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"

-- | Sets a breakpoint in pure code
breakpoint :: a -> a
breakpoint :: forall a. a -> a
breakpoint = forall a. String -> a -> a
trace String
inactivePluginStr

-- | When evaluated, displays the names of variables visible from the callsite
-- and starts a prompt where entering a variable will display its value. You
-- may want to use this instead of 'breakpoint' if there are value which should
-- stay unevaluated or you are only interested in certain values. Only the
-- current thread is blocked while the prompt is active. To resume execution,
-- press enter with a blank prompt.
queryVars :: a -> a
queryVars :: forall a. a -> a
queryVars = forall a. String -> a -> a
trace String
inactivePluginStr

-- | Similar to 'queryVars' but for use in an arbitrary 'Applicative' context.
-- This uses 'unsafePerformIO' which means that laziness and common sub-expression
-- elimination can result in unexpected behavior. For this reason you should
-- prefer 'queryVarsIO' if a 'MonadIO' instance is available.
queryVarsM :: Applicative m => m ()
queryVarsM :: forall (m :: * -> *). Applicative m => m ()
queryVarsM = forall (f :: * -> *). Applicative f => String -> f ()
traceM String
inactivePluginStr

-- | Similar to 'queryVars' but specialized to an 'IO' context. You should favor
-- this over 'queryVarsM' if a 'MonadIO' instance is available.
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)

-- | Sets a breakpoint in an arbitrary 'Applicative'. Uses 'unsafePerformIO'
-- which means that laziness and common sub-expression elimination can result
-- in the breakpoint not being hit as expected. For this reason, you should
-- prefer 'breakpointIO' if a `MonadIO` instance is available.
breakpointM :: Applicative m => m ()
breakpointM :: forall (m :: * -> *). Applicative m => m ()
breakpointM = forall (f :: * -> *). Applicative f => String -> f ()
traceM String
inactivePluginStr

-- | Sets a breakpoint in an 'IO' based 'Monad'. You should favor this over
-- 'breakpointM' if the monad can perform IO.
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)

-- | Pretty prints the source code location of its call site
getSrcLoc :: String
getSrcLoc :: String
getSrcLoc = String
""

#if MIN_VERSION_ghc(9,2,0)
-- Use an "unsafe" foreign function to more or less stop the runtime.
-- In older GHCs this can cause out of control CPU usage so settle for getLine instead
foreign import ccall unsafe "stdio.h getchar" blockOnInput :: IO Int
#else
blockOnInput :: IO Int
blockOnInput = 1 <$ getLine
#endif

-- | Excludes the given variable names from appearing in the output of any
-- breakpoints occurring in the given expression.
excludeVars :: [String] -> a -> a
excludeVars :: forall a. [String] -> a -> a
excludeVars [String]
_ = forall a. a -> a
id

--------------------------------------------------------------------------------
-- Plugin
--------------------------------------------------------------------------------

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

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

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

  let srcLocStringExpr :: GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
srcLocStringExpr
        = forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). String -> HsLit (GhcPass p)
Ghc.mkHsString
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> String
Ghc.showSDocUnsafe
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
Ghc.ppr
        forall a b. (a -> b) -> a -> b
$ forall 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

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

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

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

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

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

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

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

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

grhssCase :: Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
         -> EnvReader (Maybe (Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))
grhssCase :: GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
grhssCase Ghc.GRHSs {[LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
HsLocalBinds (GhcPass 'Renamed)
XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhssExt :: forall p body. GRHSs p body -> XCGRHSs p body
grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds :: HsLocalBinds (GhcPass 'Renamed)
grhssGRHSs :: [LGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
grhssExt :: XCGRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
..} = do
  (HsLocalBinds (GhcPass 'Renamed)
localBindsRes, VarSet
names)
    <- HsLocalBinds (GhcPass 'Renamed)
-> EnvReader (HsLocalBinds (GhcPass 'Renamed), VarSet)
dealWithLocalBinds
#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
    -- be sure to use the result names on the right so that they are overriden
    -- by any shadowing vars inside the expr.
    let rhsVars :: UniqSet Name
rhsVars
          | Bool
containsTarget
          = forall a. Uniquable a => [a] -> UniqSet a
Ghc.mkUniqSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> VarSet
resultNamesSansSelf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> VarSet
mkVarSet
            forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext
          | Bool
otherwise = XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fun_ext
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Ghc.FunBind { fun_matches :: MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
Ghc.fun_matches = MatchGroup
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
matchesRes, fun_ext :: XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
Ghc.fun_ext = UniqSet Name
rhsVars, [CoreTickish]
LIdP (GhcPass 'Renamed)
fun_id :: LIdP (GhcPass 'Renamed)
fun_tick :: [CoreTickish]
fun_tick :: [CoreTickish]
fun_id :: LIdP (GhcPass 'Renamed)
.. }

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

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

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

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

grhsCase :: Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
         -> EnvReader (Maybe (Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))
grhsCase :: GRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> EnvReader
     (Maybe (GRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))))
grhsCase (Ghc.GRHS XCGRHS (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
x [GuardLStmt (GhcPass 'Renamed)]
guards LHsExpr (GhcPass 'Renamed)
body) = do
  ([GenLocated
   (Anno
      (Stmt
         (GhcPass 'Renamed)
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))))
   (Stmt
      (GhcPass 'Renamed)
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))))]
guardsRes, VarSet
names) <- forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall body.
(Data body, Data (Stmt (GhcPass 'Renamed) body)) =>
[LStmt (GhcPass 'Renamed) body]
-> WriterT
     VarSet (WriterT Any (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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
Ghc.HsCmdTop XCmdTop (GhcPass 'Renamed)
x2 GenLocated SrcSpanAnnA (HsCmd (GhcPass 'Renamed))
cmdRes
#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

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

-- The writer is for tracking if an inner expression contains the target name
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
<>))

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

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

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

--------------------------------------------------------------------------------
-- Type Checker Plugin
--------------------------------------------------------------------------------

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 -- unlifted type
      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 [] [] -- why no use of vars here?
         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 -- Wanted instance
  -> [Ghc.Type] -- Concrete types
  -> 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 -- this lookup shouldn't fail

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]

--------------------------------------------------------------------------------
-- Showing
--------------------------------------------------------------------------------

-- | Levity polymorphic 'Show'
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

-- Looking up an instance of this class for any type will always succeed. To
-- produce actual evidence, a Show dict must be provided.
instance Show a => Succeed a where
  _succeed :: a -> String
_succeed = forall a. Show a => a -> String
show