{-# 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 = Map String String
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 :: [(k, v)] -> Map k v
fromAscList = [(k, v)] -> Map k v
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList

printAndWait :: String -> M.Map String String -> a -> a
printAndWait :: String -> Map String String -> a -> a
printAndWait String
srcLoc Map String String
vars a
x =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> Map String String -> IO ()
forall (m :: * -> *).
MonadIO m =>
String -> Map String String -> m ()
printAndWaitIO String
srcLoc Map String String
vars IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
{-# NOINLINE printAndWait #-}

printAndWaitM :: Applicative m => String -> M.Map String String -> m ()
printAndWaitM :: String -> Map String String -> m ()
printAndWaitM String
srcLoc Map String String
vars = String -> Map String String -> m () -> m ()
forall a. String -> Map String String -> a -> a
printAndWait String
srcLoc Map String String
vars (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

printAndWaitIO :: MonadIO m => String -> M.Map String String -> m ()
printAndWaitIO :: String -> Map String String -> m ()
printAndWaitIO String
srcLoc Map String String
vars = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Bool
useColor <- Handle -> IO Bool
ANSI.hSupportsANSIColor Handle
stdout
  let ?useColor = useColor
  Bool
prettyPrint <- IO Bool
usePrettyPrinting
  let ?prettyPrint = prettyPrint
  IO () -> IO ()
forall a. IO a -> IO a
TM.suspendTimeouts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
traceIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n"
      [ (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
red String
"### Breakpoint Hit ###"
      , (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
grey String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
srcLoc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
      , (?useColor::Bool, ?prettyPrint::Bool) =>
Map String String -> String
Map String String -> String
printVars Map String String
vars
      , (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
green String
"Press enter to continue"
      ]
    IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Int
blockOnInput

runPrompt :: String -> M.Map String String -> a -> a
runPrompt :: String -> Map String String -> a -> a
runPrompt String
srcLoc Map String String
vars a
x =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> Map String String -> IO ()
forall (m :: * -> *).
MonadIO m =>
String -> Map String String -> m ()
runPromptIO String
srcLoc Map String String
vars IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
{-# NOINLINE runPrompt #-}

runPromptM :: Applicative m => String -> M.Map String String -> m ()
runPromptM :: String -> Map String String -> m ()
runPromptM String
srcLoc Map String String
vars = String -> Map String String -> m () -> m ()
forall a. String -> Map String String -> a -> a
runPrompt String
srcLoc Map String String
vars (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runPromptIO :: forall m. MonadIO m => String -> M.Map String String -> m ()
runPromptIO :: String -> Map String String -> m ()
runPromptIO String
srcLoc Map String String
vars = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (InputT IO () -> IO ()) -> InputT IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behavior -> Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Behavior -> Settings m -> InputT m a -> m a
HL.runInputTBehavior Behavior
HL.defaultBehavior Settings IO
settings (InputT IO () -> m ()) -> InputT IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
useColor <- IO Bool -> InputT IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> InputT IO Bool) -> IO Bool -> InputT IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
ANSI.hSupportsANSIColor Handle
stdout
    let ?useColor = useColor
    Bool
prettyPrint <- IO Bool -> InputT IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
usePrettyPrinting
    let ?prettyPrint = prettyPrint
    let printVar :: String -> String -> InputT m ()
printVar String
var String
val =
          String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
HL.outputStrLn (String -> InputT m ()) -> String -> InputT m ()
forall a b. (a -> b) -> a -> b
$ (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
cyan (String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =\n") String -> String -> String
forall a. [a] -> [a] -> [a]
++ (?prettyPrint::Bool) => String -> String
String -> String
prettify String
val
        inputLoop :: InputT IO ()
inputLoop = do
          Maybe String
mInp <- String -> InputT IO (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
HL.getInputLine (String -> InputT IO (Maybe String))
-> String -> InputT IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
green String
"Enter variable name: "
          case Maybe String
mInp of
            Just ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace -> String
inp)
              | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
inp) -> do
                  (String -> InputT IO ()) -> Maybe String -> InputT IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (String -> String -> InputT IO ()
forall (m :: * -> *).
(MonadIO m, ?prettyPrint::Bool, ?useColor::Bool) =>
String -> String -> InputT m ()
printVar String
inp) (Maybe String -> InputT IO ()) -> Maybe String -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
inp Map String String
vars
                  InputT IO ()
inputLoop
            Maybe String
_ -> () -> InputT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    String -> InputT IO ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
HL.outputStrLn (String -> InputT IO ())
-> ([String] -> String) -> [String] -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> InputT IO ()) -> [String] -> InputT IO ()
forall a b. (a -> b) -> a -> b
$
      [ (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
red String
"### Breakpoint Hit ###"
      , (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
grey (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
srcLoc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
      ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((?useColor::Bool) => String -> String -> String
String -> String -> String
color String
cyan (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
varNames)
    InputT IO ()
inputLoop
  where
    settings :: Settings IO
settings = CompletionFunc IO -> Settings IO -> Settings IO
forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
HL.setComplete CompletionFunc IO
completion Settings IO
forall (m :: * -> *). MonadIO m => Settings m
HL.defaultSettings
    completion :: CompletionFunc IO
completion = Maybe Char
-> (Char -> Bool)
-> (String -> IO [Completion])
-> CompletionFunc IO
forall (m :: * -> *).
Monad m =>
Maybe Char
-> (Char -> Bool) -> (String -> m [Completion]) -> CompletionFunc m
HL.completeWord' Maybe Char
forall a. Maybe a
Nothing Char -> Bool
isSpace ((String -> IO [Completion]) -> CompletionFunc IO)
-> (String -> IO [Completion]) -> CompletionFunc IO
forall a b. (a -> b) -> a -> b
$ \String
str ->
      [Completion] -> IO [Completion]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Completion] -> IO [Completion])
-> [Completion] -> IO [Completion]
forall a b. (a -> b) -> a -> b
$ String -> Completion
HL.simpleCompletion
        (String -> Completion) -> [String] -> [Completion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
str String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf`) [String]
varNames
    varNames :: [String]
varNames = Map String String -> [String]
forall k a. Map k a -> [k]
M.keys Map String String
vars

usePrettyPrinting :: IO Bool
usePrettyPrinting :: IO Bool
usePrettyPrinting = Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
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 :: String -> String -> String
color String
c String
s =
  if ?useColor::Bool
Bool
?useColor
     then String
"\ESC[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"m\STX" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
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 :: Map String String -> String
printVars Map String String
vars =
  let eqSign :: String
eqSign | ?prettyPrint::Bool
Bool
?prettyPrint = String
" =\n"
             | Bool
otherwise = String
" = "
      mkLine :: (String, String) -> String
mkLine (String
k, String
v) = (?useColor::Bool) => String -> String -> String
String -> String -> String
color String
cyan (String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
eqSign) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (?prettyPrint::Bool) => String -> String
String -> String
prettify String
v
   in [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
"" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (?prettyPrint::Bool, ?useColor::Bool) => (String, String) -> String
(String, String) -> String
mkLine ((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String String -> [(String, String)]
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 :: String -> String
prettify =
  if ?prettyPrint::Bool
Bool
?prettyPrint
  then Text -> String
T.unpack
     (Text -> String) -> (String -> Text) -> String -> String
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 = ColorOptions -> Maybe ColorOptions
forall a. a -> Maybe a
Just ColorOptions :: Style -> Style -> Style -> Style -> [Style] -> ColorOptions
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 String -> String
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 :: a -> a
breakpoint = String -> a -> a
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 :: a -> a
queryVars = String -> a -> a
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 :: m ()
queryVarsM = String -> m ()
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 :: m ()
queryVarsIO =
  IO () -> m ()
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 :: m ()
breakpointM = String -> m ()
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 :: m ()
breakpointIO =
  IO () -> m ()
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 :: IO Int
blockOnInput = Int
1 Int -> IO String -> IO Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO String
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 :: [String] -> a -> a
excludeVars [String]
_ = a -> a
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 GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
Ghc.renamedResultAction = (TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn))
-> [String]
-> TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
forall a b. a -> b -> a
const TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
renameAction
  , tcPlugin :: TcPlugin
Ghc.tcPlugin = Maybe TcPlugin -> TcPlugin
forall a b. a -> b -> a
const (Maybe TcPlugin -> TcPlugin) -> Maybe TcPlugin -> TcPlugin
forall a b. (a -> b) -> a -> b
$ TcPlugin -> Maybe TcPlugin
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 GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
renameAction TcGblEnv
gblEnv HsGroup GhcRn
group = do
  Ghc.Found ModLocation
_ Module
breakpointMod <-
    ModuleName -> TcM FindResult
Ghc.findPluginModule' (String -> ModuleName
Ghc.mkModuleName String
"Debug.Breakpoint")

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

  (HsGroup GhcRn
group', Any
_) <-
    ReaderT Env TcM (HsGroup GhcRn, Any)
-> Env -> TcM (HsGroup GhcRn, Any)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (WriterT Any (ReaderT Env TcM) (HsGroup GhcRn)
-> ReaderT Env TcM (HsGroup GhcRn, Any)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT (WriterT Any (ReaderT Env TcM) (HsGroup GhcRn)
 -> ReaderT Env TcM (HsGroup GhcRn, Any))
-> WriterT Any (ReaderT Env TcM) (HsGroup GhcRn)
-> ReaderT Env TcM (HsGroup GhcRn, Any)
forall a b. (a -> b) -> a -> b
$ HsGroup GhcRn -> WriterT Any (ReaderT Env TcM) (HsGroup GhcRn)
forall a. Data a => a -> EnvReader a
recurse HsGroup GhcRn
group)
      MkEnv :: VarSet
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Env
MkEnv { varSet :: 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
.. }

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

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

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

hsVarCase :: Ghc.HsExpr Ghc.GhcRn
          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))
hsVarCase :: HsExpr GhcRn -> EnvReader (Maybe (HsExpr GhcRn))
hsVarCase (Ghc.HsVar XVar GhcRn
_ (Ghc.L SrcSpan
loc IdP GhcRn
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
..} <- ReaderT Env TcM Env -> WriterT Any (ReaderT Env TcM) Env
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT Env TcM Env
forall r (m :: * -> *). MonadReader r m => m r
ask

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

      captureVarsExpr :: Maybe Name -> LHsExpr GhcRn
captureVarsExpr Maybe Name
mResultName =
        let mkTuple :: (LexicalFastString', Name) -> LHsExpr GhcRn
mkTuple (LexicalFastString' -> LexicalFastString'
Ghc.fromLexicalFastString -> LexicalFastString'
varStr, Name
n) =
              [LHsExpr GhcRn] -> LHsExpr GhcRn
forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
Ghc.mkLHsTupleExpr
                [ HsLit GhcRn -> LHsExpr GhcRn
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
Ghc.nlHsLit (HsLit GhcRn -> LHsExpr GhcRn)
-> (String -> HsLit GhcRn) -> String -> LHsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcRn
forall (p :: Pass). String -> HsLit (GhcPass p)
Ghc.mkHsString (String -> LHsExpr GhcRn) -> String -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ LexicalFastString' -> String
Ghc.unpackFS LexicalFastString'
varStr
                , LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsVar IdP GhcRn
Name
showLevName) (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsVar IdP GhcRn
Name
n)
                ]
#if MIN_VERSION_ghc(9,2,0)
                Ghc.NoExtField
#endif

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

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

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

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

      bpMExpr :: LHsExpr GhcRn
bpMExpr =
        LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsVar IdP GhcRn
Name
printAndWaitMName) LHsExpr GhcRn
srcLocStringExpr)
          (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Maybe Name -> LHsExpr GhcRn
captureVarsExpr Maybe Name
forall a. Maybe a
Nothing

      bpIOExpr :: LHsExpr GhcRn
bpIOExpr =
        LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsVar IdP GhcRn
Name
printAndWaitIOName) LHsExpr GhcRn
srcLocStringExpr)
          (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Maybe Name -> LHsExpr GhcRn
captureVarsExpr Maybe Name
forall a. Maybe a
Nothing

      queryVarsIOExpr :: LHsExpr GhcRn
queryVarsIOExpr =
        LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsVar IdP GhcRn
Name
runPromptIOName) LHsExpr GhcRn
srcLocStringExpr)
          (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Maybe Name -> LHsExpr GhcRn
captureVarsExpr Maybe Name
forall a. Maybe a
Nothing

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

      queryVarsMExpr :: LHsExpr GhcRn
queryVarsMExpr =
        LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp
          (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsApp (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
Ghc.nlHsVar IdP GhcRn
Name
runPromptMName) LHsExpr GhcRn
srcLocStringExpr)
          (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Maybe Name -> LHsExpr GhcRn
captureVarsExpr Maybe Name
forall a. Maybe a
Nothing

  if | Name
captureVarsName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> (LHsExpr GhcRn -> HsExpr GhcRn)
-> LHsExpr GhcRn
-> Maybe (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc (LHsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ Maybe Name -> LHsExpr GhcRn
captureVarsExpr Maybe Name
forall a. Maybe a
Nothing)

     | Name
breakpointName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> (LHsExpr GhcRn -> HsExpr GhcRn)
-> LHsExpr GhcRn
-> Maybe (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc (LHsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env TcM (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
-> ReaderT Env TcM (LHsExpr GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
bpExpr)

     | Name
breakpointMName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsExpr GhcRn
bpMExpr)

     | Name
breakpointIOName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsExpr GhcRn
bpIOExpr)

     | Name
queryVarsIOName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsExpr GhcRn
queryVarsIOExpr)

     | Name
queryVarsName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> (LHsExpr GhcRn -> HsExpr GhcRn)
-> LHsExpr GhcRn
-> Maybe (HsExpr GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc (LHsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env TcM (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
-> ReaderT Env TcM (LHsExpr GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
queryVarsExpr)

     | Name
queryVarsMName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name -> do
         Any -> WriterT Any (ReaderT Env TcM) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (Any -> WriterT Any (ReaderT Env TcM) ())
-> Any -> WriterT Any (ReaderT Env TcM) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
         Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsExpr GhcRn
queryVarsMExpr)

     | Name
getSrcLocName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
name ->
         Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsExpr GhcRn
srcLocStringExpr)

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

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

hsAppCase :: Ghc.LHsExpr Ghc.GhcRn
          -> EnvReader (Maybe (Ghc.LHsExpr Ghc.GhcRn))
hsAppCase :: LHsExpr GhcRn -> EnvReader (Maybe (LHsExpr GhcRn))
hsAppCase (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc -> Ghc.HsApp _ f innerExpr)
  | Ghc.HsApp _ (Ghc.unLoc -> Ghc.HsVar _ (Ghc.unLoc -> name))
                (Ghc.unLoc -> Ghc.ExplicitList' _ exprsToExclude)
      <- LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsExpr GhcRn
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
..} <- ReaderT Env TcM Env -> WriterT Any (ReaderT Env TcM) Env
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT Env TcM Env
forall r (m :: * -> *). MonadReader r m => m r
ask
    if Name
excludeVarsName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpanLess (Located Name)
Name
name
       then Maybe (LHsExpr GhcRn) -> EnvReader (Maybe (LHsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LHsExpr GhcRn)
forall a. Maybe a
Nothing
       else do
         let extractVarName :: HsExpr GhcRn -> Maybe LexicalFastString'
extractVarName (Ghc.HsLit XLitE GhcRn
_ (Ghc.HsString XHsString GhcRn
_ LexicalFastString'
fs)) =
               LexicalFastString' -> Maybe LexicalFastString'
forall a. a -> Maybe a
Just (LexicalFastString' -> Maybe LexicalFastString')
-> LexicalFastString' -> Maybe LexicalFastString'
forall a b. (a -> b) -> a -> b
$ LexicalFastString' -> LexicalFastString'
Ghc.mkLexicalFastString LexicalFastString'
fs
             extractVarName (Ghc.HsOverLit XOverLitE GhcRn
_ (Ghc.OverLit' (Ghc.HsIsString SourceText
_ LexicalFastString'
fs))) =
               LexicalFastString' -> Maybe LexicalFastString'
forall a. a -> Maybe a
Just (LexicalFastString' -> Maybe LexicalFastString')
-> LexicalFastString' -> Maybe LexicalFastString'
forall a b. (a -> b) -> a -> b
$ LexicalFastString' -> LexicalFastString'
Ghc.mkLexicalFastString LexicalFastString'
fs
             extractVarName HsExpr GhcRn
_ = Maybe LexicalFastString'
forall a. Maybe a
Nothing

             varsToExclude :: [LexicalFastString']
varsToExclude =
               (LHsExpr GhcRn -> Maybe LexicalFastString')
-> [LHsExpr GhcRn] -> [LexicalFastString']
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HsExpr GhcRn -> Maybe LexicalFastString'
extractVarName (HsExpr GhcRn -> Maybe LexicalFastString')
-> (LHsExpr GhcRn -> HsExpr GhcRn)
-> LHsExpr GhcRn
-> Maybe LexicalFastString'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcRn -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc) [LHsExpr GhcRn]
exprsToExclude

         LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> Maybe (LHsExpr GhcRn))
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> EnvReader (Maybe (LHsExpr GhcRn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           (ReaderT Env TcM (LHsExpr GhcRn, Any)
 -> ReaderT Env TcM (LHsExpr GhcRn, Any))
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
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
            ((Env -> Env)
-> ReaderT Env TcM (LHsExpr GhcRn, Any)
-> ReaderT Env TcM (LHsExpr GhcRn, Any)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((VarSet -> VarSet) -> Env -> Env
overVarSet ((VarSet -> VarSet) -> Env -> Env)
-> (VarSet -> VarSet) -> Env -> Env
forall a b. (a -> b) -> a -> b
$ \VarSet
vs -> (LexicalFastString' -> VarSet -> VarSet)
-> VarSet -> [LexicalFastString'] -> VarSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LexicalFastString' -> VarSet -> VarSet
forall k a. Ord k => k -> Map k a -> Map k a
M.delete VarSet
vs [LexicalFastString']
varsToExclude))
            (LHsExpr GhcRn -> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a. Data a => a -> EnvReader a
recurse LHsExpr GhcRn
innerExpr)
hsAppCase LHsExpr GhcRn
_ = Maybe (LHsExpr GhcRn) -> EnvReader (Maybe (LHsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LHsExpr GhcRn)
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 GhcRn (LHsExpr GhcRn)
-> EnvReader (Maybe (Match GhcRn (LHsExpr GhcRn)))
matchCase Ghc.Match {[LPat GhcRn]
HsMatchContext (NameOrRdrName (IdP GhcRn))
GRHSs GhcRn (LHsExpr GhcRn)
XCMatch GhcRn (LHsExpr GhcRn)
m_ext :: forall p body. Match p body -> XCMatch p body
m_ctxt :: forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_pats :: forall p body. Match p body -> [LPat p]
m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss :: GRHSs GhcRn (LHsExpr GhcRn)
m_pats :: [LPat GhcRn]
m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcRn))
m_ext :: XCMatch GhcRn (LHsExpr GhcRn)
..} = do
  let names :: VarSet
names = (Located (Pat GhcRn) -> VarSet) -> [Located (Pat GhcRn)] -> VarSet
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LPat GhcRn -> VarSet
Located (Pat GhcRn) -> VarSet
extractVarPats [LPat GhcRn]
[Located (Pat GhcRn)]
m_pats
  GRHSs GhcRn (LHsExpr GhcRn)
grhRes <- VarSet
-> EnvReader (GRHSs GhcRn (LHsExpr GhcRn))
-> EnvReader (GRHSs GhcRn (LHsExpr GhcRn))
forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names (EnvReader (GRHSs GhcRn (LHsExpr GhcRn))
 -> EnvReader (GRHSs GhcRn (LHsExpr GhcRn)))
-> EnvReader (GRHSs GhcRn (LHsExpr GhcRn))
-> EnvReader (GRHSs GhcRn (LHsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ GRHSs GhcRn (LHsExpr GhcRn)
-> EnvReader (GRHSs GhcRn (LHsExpr GhcRn))
forall a. Data a => a -> EnvReader a
recurse GRHSs GhcRn (LHsExpr GhcRn)
m_grhss
  Maybe (Match GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (Match GhcRn (LHsExpr GhcRn)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Match GhcRn (LHsExpr GhcRn))
 -> EnvReader (Maybe (Match GhcRn (LHsExpr GhcRn))))
-> Maybe (Match GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (Match GhcRn (LHsExpr GhcRn)))
forall a b. (a -> b) -> a -> b
$ Match GhcRn (LHsExpr GhcRn) -> Maybe (Match GhcRn (LHsExpr GhcRn))
forall a. a -> Maybe a
Just
    Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Ghc.Match { m_grhss :: GRHSs GhcRn (LHsExpr GhcRn)
Ghc.m_grhss = GRHSs GhcRn (LHsExpr GhcRn)
grhRes, [LPat GhcRn]
HsMatchContext (NameOrRdrName (IdP GhcRn))
XCMatch GhcRn (LHsExpr GhcRn)
m_ext :: XCMatch GhcRn (LHsExpr GhcRn)
m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcRn))
m_pats :: [LPat GhcRn]
m_pats :: [LPat GhcRn]
m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcRn))
m_ext :: XCMatch GhcRn (LHsExpr GhcRn)
.. }
#if !MIN_VERSION_ghc(9,0,0)
matchCase Match GhcRn (LHsExpr GhcRn)
_ = Maybe (Match GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (Match GhcRn (LHsExpr GhcRn)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Match GhcRn (LHsExpr GhcRn))
forall a. Maybe a
Nothing
#endif

extractVarPats :: Ghc.LPat Ghc.GhcRn -> VarSet
extractVarPats :: LPat GhcRn -> VarSet
extractVarPats = [Name] -> VarSet
mkVarSet ([Name] -> VarSet)
-> (Located (Pat GhcRn) -> [Name]) -> Located (Pat GhcRn) -> VarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPat GhcRn -> [Name]
Located (Pat GhcRn) -> [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 GhcRn (LHsExpr GhcRn)
-> EnvReader (Maybe (GRHSs GhcRn (LHsExpr GhcRn)))
grhssCase Ghc.GRHSs {[LGRHS GhcRn (LHsExpr GhcRn)]
XCGRHSs GhcRn (LHsExpr GhcRn)
LHsLocalBinds GhcRn
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 -> LHsLocalBinds p
grhssLocalBinds :: LHsLocalBinds GhcRn
grhssGRHSs :: [LGRHS GhcRn (LHsExpr GhcRn)]
grhssExt :: XCGRHSs GhcRn (LHsExpr GhcRn)
..} = do
  (HsLocalBinds GhcRn
localBindsRes, VarSet
names)
    <- HsLocalBinds GhcRn -> EnvReader (HsLocalBinds GhcRn, VarSet)
dealWithLocalBinds
#if MIN_VERSION_ghc(9,2,0)
         grhssLocalBinds
#else
         (LHsLocalBinds GhcRn -> SrcSpanLess (LHsLocalBinds GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsLocalBinds GhcRn
grhssLocalBinds)
#endif

  [LGRHS GhcRn (LHsExpr GhcRn)]
grhsRes <- VarSet
-> EnvReader [LGRHS GhcRn (LHsExpr GhcRn)]
-> EnvReader [LGRHS GhcRn (LHsExpr GhcRn)]
forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names (EnvReader [LGRHS GhcRn (LHsExpr GhcRn)]
 -> EnvReader [LGRHS GhcRn (LHsExpr GhcRn)])
-> EnvReader [LGRHS GhcRn (LHsExpr GhcRn)]
-> EnvReader [LGRHS GhcRn (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ [LGRHS GhcRn (LHsExpr GhcRn)]
-> EnvReader [LGRHS GhcRn (LHsExpr GhcRn)]
forall a. Data a => a -> EnvReader a
recurse [LGRHS GhcRn (LHsExpr GhcRn)]
grhssGRHSs
  Maybe (GRHSs GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (GRHSs GhcRn (LHsExpr GhcRn)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GRHSs GhcRn (LHsExpr GhcRn))
 -> EnvReader (Maybe (GRHSs GhcRn (LHsExpr GhcRn))))
-> Maybe (GRHSs GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (GRHSs GhcRn (LHsExpr GhcRn)))
forall a b. (a -> b) -> a -> b
$ GRHSs GhcRn (LHsExpr GhcRn) -> Maybe (GRHSs GhcRn (LHsExpr GhcRn))
forall a. a -> Maybe a
Just
    GRHSs :: forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
Ghc.GRHSs { grhssGRHSs :: [LGRHS GhcRn (LHsExpr GhcRn)]
Ghc.grhssGRHSs = [LGRHS GhcRn (LHsExpr GhcRn)]
grhsRes
#if MIN_VERSION_ghc(9,2,0)
              , grhssLocalBinds = localBindsRes
#else
              , grhssLocalBinds :: LHsLocalBinds GhcRn
grhssLocalBinds = HsLocalBinds GhcRn
localBindsRes HsLocalBinds GhcRn -> LHsLocalBinds GhcRn -> LHsLocalBinds GhcRn
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsLocalBinds GhcRn
grhssLocalBinds
#endif
              , XCGRHSs GhcRn (LHsExpr GhcRn)
grhssExt :: XCGRHSs GhcRn (LHsExpr GhcRn)
grhssExt :: XCGRHSs GhcRn (LHsExpr GhcRn)
..
              }
#if !MIN_VERSION_ghc(9,0,0)
grhssCase GRHSs GhcRn (LHsExpr GhcRn)
_ = Maybe (GRHSs GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (GRHSs GhcRn (LHsExpr GhcRn)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GRHSs GhcRn (LHsExpr GhcRn))
forall a. Maybe a
Nothing
#endif

dealWithBind :: VarSet
             -> Ghc.LHsBind Ghc.GhcRn
             -> EnvReader (Ghc.LHsBind Ghc.GhcRn)
dealWithBind :: VarSet -> LHsBind GhcRn -> EnvReader (LHsBind GhcRn)
dealWithBind VarSet
resultNames LHsBind GhcRn
lbind = LHsBind GhcRn
-> (HsBindLR GhcRn GhcRn
    -> WriterT Any (ReaderT Env TcM) (HsBindLR GhcRn GhcRn))
-> EnvReader (LHsBind GhcRn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for LHsBind GhcRn
lbind ((HsBindLR GhcRn GhcRn
  -> WriterT Any (ReaderT Env TcM) (HsBindLR GhcRn GhcRn))
 -> EnvReader (LHsBind GhcRn))
-> (HsBindLR GhcRn GhcRn
    -> WriterT Any (ReaderT Env TcM) (HsBindLR GhcRn GhcRn))
-> EnvReader (LHsBind GhcRn)
forall a b. (a -> b) -> a -> b
$ \case
  Ghc.FunBind {[Tickish Id]
HsWrapper
MatchGroup GhcRn (LHsExpr GhcRn)
XFunBind GhcRn GhcRn
GenLocated SrcSpan (IdP GhcRn)
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_co_fn :: forall idL idR. HsBindLR idL idR -> HsWrapper
fun_tick :: forall idL idR. HsBindLR idL idR -> [Tickish Id]
fun_tick :: [Tickish Id]
fun_co_fn :: HsWrapper
fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_id :: GenLocated SrcSpan (IdP GhcRn)
fun_ext :: XFunBind GhcRn GhcRn
..} -> do
    let resultNamesSansSelf :: VarSet
resultNamesSansSelf =
          LexicalFastString' -> VarSet -> VarSet
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (Name -> LexicalFastString'
getOccNameFS (Name -> LexicalFastString') -> Name -> LexicalFastString'
forall a b. (a -> b) -> a -> b
$ Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc GenLocated SrcSpan (IdP GhcRn)
Located Name
fun_id) VarSet
resultNames
    (MatchGroup GhcRn (LHsExpr GhcRn)
matchesRes, Any Bool
containsTarget)
      <- WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
-> WriterT
     Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn), Any)
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen
       (WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
 -> WriterT
      Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn), Any))
-> (WriterT
      Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
    -> WriterT
         Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn)))
-> WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
-> WriterT
     Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn), Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarSet
-> WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
-> WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
resultNamesSansSelf
       (WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
 -> WriterT
      Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn), Any))
-> WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
-> WriterT
     Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn), Any)
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcRn (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (MatchGroup GhcRn (LHsExpr GhcRn))
forall a. Data a => a -> EnvReader a
recurse MatchGroup GhcRn (LHsExpr GhcRn)
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
          = [Name] -> UniqSet Name
forall a. Uniquable a => [a] -> UniqSet a
Ghc.mkUniqSet ([Name] -> UniqSet Name)
-> ([Name] -> [Name]) -> [Name] -> UniqSet Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarSet -> [Name]
forall k a. Map k a -> [a]
M.elems
            (VarSet -> [Name]) -> ([Name] -> VarSet) -> [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarSet -> VarSet -> VarSet
forall a. Semigroup a => a -> a -> a
<> VarSet
resultNamesSansSelf) (VarSet -> VarSet) -> ([Name] -> VarSet) -> [Name] -> VarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> VarSet
mkVarSet
            ([Name] -> UniqSet Name) -> [Name] -> UniqSet Name
forall a b. (a -> b) -> a -> b
$ UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet XFunBind GhcRn GhcRn
UniqSet Name
fun_ext
          | Bool
otherwise = XFunBind GhcRn GhcRn
UniqSet Name
fun_ext
    HsBindLR GhcRn GhcRn
-> WriterT Any (ReaderT Env TcM) (HsBindLR GhcRn GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
Ghc.FunBind { fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
Ghc.fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matchesRes, fun_ext :: XFunBind GhcRn GhcRn
Ghc.fun_ext = XFunBind GhcRn GhcRn
UniqSet Name
rhsVars, [Tickish Id]
HsWrapper
GenLocated SrcSpan (IdP GhcRn)
fun_id :: GenLocated SrcSpan (IdP GhcRn)
fun_co_fn :: HsWrapper
fun_tick :: [Tickish Id]
fun_tick :: [Tickish Id]
fun_co_fn :: HsWrapper
fun_id :: GenLocated SrcSpan (IdP GhcRn)
.. }

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

  -- Does this not occur in the renamer?
  Ghc.VarBind {Bool
IdP GhcRn
XVarBind GhcRn GhcRn
LHsExpr GhcRn
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_inline :: forall idL idR. HsBindLR idL idR -> Bool
var_inline :: Bool
var_rhs :: LHsExpr GhcRn
var_id :: IdP GhcRn
var_ext :: XVarBind GhcRn GhcRn
..} -> do
    LHsExpr GhcRn
rhsRes
      <- VarSet
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
resultNames
       (WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
 -> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn))
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a. Data a => a -> EnvReader a
recurse LHsExpr GhcRn
var_rhs
    HsBindLR GhcRn GhcRn
-> WriterT Any (ReaderT Env TcM) (HsBindLR GhcRn GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure VarBind :: forall idL idR.
XVarBind idL idR
-> IdP idL -> LHsExpr idR -> Bool -> HsBindLR idL idR
Ghc.VarBind { var_rhs :: LHsExpr GhcRn
Ghc.var_rhs = LHsExpr GhcRn
rhsRes, Bool
IdP GhcRn
XVarBind GhcRn GhcRn
var_ext :: XVarBind GhcRn GhcRn
var_id :: IdP GhcRn
var_inline :: Bool
var_inline :: Bool
var_id :: IdP GhcRn
var_ext :: XVarBind GhcRn GhcRn
.. }

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

#if !MIN_VERSION_ghc(9,4,0)
  HsBindLR GhcRn GhcRn
other -> HsBindLR GhcRn GhcRn
-> WriterT Any (ReaderT Env TcM) (HsBindLR GhcRn GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsBindLR GhcRn GhcRn
other
#endif

grhsCase :: Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
         -> EnvReader (Maybe (Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))
grhsCase :: GRHS GhcRn (LHsExpr GhcRn)
-> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn)))
grhsCase (Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x [GuardLStmt GhcRn]
guards LHsExpr GhcRn
body) = do
  ([GuardLStmt GhcRn]
guardsRes, VarSet
names) <- WriterT VarSet EnvReader [GuardLStmt GhcRn]
-> EnvReader ([GuardLStmt GhcRn], VarSet)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT (WriterT VarSet EnvReader [GuardLStmt GhcRn]
 -> EnvReader ([GuardLStmt GhcRn], VarSet))
-> WriterT VarSet EnvReader [GuardLStmt GhcRn]
-> EnvReader ([GuardLStmt GhcRn], VarSet)
forall a b. (a -> b) -> a -> b
$ [GuardLStmt GhcRn] -> WriterT VarSet EnvReader [GuardLStmt GhcRn]
forall body.
(Data body, Data (Stmt GhcRn body)) =>
[LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
dealWithStatements [GuardLStmt GhcRn]
guards
  LHsExpr GhcRn
bodyRes <- VarSet
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names (WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
 -> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn))
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
-> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> WriterT Any (ReaderT Env TcM) (LHsExpr GhcRn)
forall a. Data a => a -> EnvReader a
recurse LHsExpr GhcRn
body
  Maybe (GRHS GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GRHS GhcRn (LHsExpr GhcRn))
 -> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn))))
-> (GRHS GhcRn (LHsExpr GhcRn)
    -> Maybe (GRHS GhcRn (LHsExpr GhcRn)))
-> GRHS GhcRn (LHsExpr GhcRn)
-> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRHS GhcRn (LHsExpr GhcRn) -> Maybe (GRHS GhcRn (LHsExpr GhcRn))
forall a. a -> Maybe a
Just (GRHS GhcRn (LHsExpr GhcRn)
 -> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn))))
-> GRHS GhcRn (LHsExpr GhcRn)
-> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn)))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcRn (LHsExpr GhcRn)
-> [GuardLStmt GhcRn]
-> LHsExpr GhcRn
-> GRHS GhcRn (LHsExpr GhcRn)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
Ghc.GRHS XCGRHS GhcRn (LHsExpr GhcRn)
x [GuardLStmt GhcRn]
guardsRes LHsExpr GhcRn
bodyRes
#if !MIN_VERSION_ghc(9,0,0)
grhsCase GRHS GhcRn (LHsExpr GhcRn)
_ = Maybe (GRHS GhcRn (LHsExpr GhcRn))
-> EnvReader (Maybe (GRHS GhcRn (LHsExpr GhcRn)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GRHS GhcRn (LHsExpr GhcRn))
forall a. Maybe a
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 GhcRn -> EnvReader (Maybe (HsExpr GhcRn))
hsLetCase (Ghc.HsLet' XLet GhcRn
x ()
letToken (Ghc.L SrcSpan
loc HsLocalBinds GhcRn
localBinds) ()
inToken LHsExpr GhcRn
inExpr) = do
  (HsLocalBinds GhcRn
bindsRes, VarSet
names) <- HsLocalBinds GhcRn -> EnvReader (HsLocalBinds GhcRn, VarSet)
dealWithLocalBinds HsLocalBinds GhcRn
localBinds

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

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

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

      if Bool -> Bool
not Bool
containsTarget
         then (HsLocalBinds GhcRn, VarSet)
-> EnvReader (HsLocalBinds GhcRn, VarSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsLocalBinds GhcRn
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 GhcRn GhcRn), b)
-> (t (HsBindLR GhcRn GhcRn), b, UniqSet Name)
mkTuple (t (HsBindLR GhcRn GhcRn)
bind, b
ns)
                 = (t (HsBindLR GhcRn GhcRn)
bind, b
ns, (HsBindLR GhcRn GhcRn -> UniqSet Name)
-> t (HsBindLR GhcRn GhcRn) -> UniqSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsBindLR GhcRn GhcRn -> UniqSet Name
getRhsFreeVars t (HsBindLR GhcRn GhcRn)
bind)

               finalResult :: [(RecFlag, Bag (LHsBind GhcRn))]
finalResult = [(LHsBind GhcRn, [Name], UniqSet Name)]
-> [(RecFlag, Bag (LHsBind GhcRn))]
depAnalBinds ([(LHsBind GhcRn, [Name], UniqSet Name)]
 -> [(RecFlag, Bag (LHsBind GhcRn))])
-> [(LHsBind GhcRn, [Name], UniqSet Name)]
-> [(RecFlag, Bag (LHsBind GhcRn))]
forall a b. (a -> b) -> a -> b
$ (LHsBind GhcRn, [Name]) -> (LHsBind GhcRn, [Name], UniqSet Name)
forall (t :: * -> *) b.
Foldable t =>
(t (HsBindLR GhcRn GhcRn), b)
-> (t (HsBindLR GhcRn GhcRn), b, UniqSet Name)
mkTuple ((LHsBind GhcRn, [Name]) -> (LHsBind GhcRn, [Name], UniqSet Name))
-> [(LHsBind GhcRn, [Name])]
-> [(LHsBind GhcRn, [Name], UniqSet Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LHsBind GhcRn, [Name])]
resBindsWithNames

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

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

  HsLocalBinds GhcRn
other -> (HsLocalBinds GhcRn, VarSet)
-> EnvReader (HsLocalBinds GhcRn, VarSet)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsLocalBinds GhcRn
other, VarSet
forall a. Monoid a => a
mempty)

getRhsFreeVars :: Ghc.HsBind Ghc.GhcRn -> Ghc.UniqSet Ghc.Name
getRhsFreeVars :: HsBindLR GhcRn GhcRn -> UniqSet Name
getRhsFreeVars = \case
  Ghc.FunBind {[Tickish Id]
HsWrapper
MatchGroup GhcRn (LHsExpr GhcRn)
XFunBind GhcRn GhcRn
GenLocated SrcSpan (IdP GhcRn)
fun_tick :: [Tickish Id]
fun_co_fn :: HsWrapper
fun_matches :: MatchGroup GhcRn (LHsExpr GhcRn)
fun_id :: GenLocated SrcSpan (IdP GhcRn)
fun_ext :: XFunBind GhcRn GhcRn
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_co_fn :: forall idL idR. HsBindLR idL idR -> HsWrapper
fun_tick :: forall idL idR. HsBindLR idL idR -> [Tickish Id]
..} -> XFunBind GhcRn GhcRn
UniqSet Name
fun_ext
  Ghc.PatBind {([Tickish Id], [[Tickish Id]])
GRHSs GhcRn (LHsExpr GhcRn)
LPat GhcRn
XPatBind GhcRn GhcRn
pat_ticks :: ([Tickish Id], [[Tickish Id]])
pat_rhs :: GRHSs GhcRn (LHsExpr GhcRn)
pat_lhs :: LPat GhcRn
pat_ext :: XPatBind GhcRn GhcRn
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 -> ([Tickish Id], [[Tickish Id]])
..} -> XPatBind GhcRn GhcRn
UniqSet Name
pat_ext
  Ghc.PatSynBind XPatSynBind GhcRn GhcRn
_ Ghc.PSB {HsPatSynDir GhcRn
HsPatSynDetails (GenLocated SrcSpan (IdP GhcRn))
LPat GhcRn
XPSB GhcRn GhcRn
GenLocated SrcSpan (IdP GhcRn)
psb_dir :: HsPatSynDir GhcRn
psb_def :: LPat GhcRn
psb_args :: HsPatSynDetails (GenLocated SrcSpan (IdP GhcRn))
psb_id :: GenLocated SrcSpan (IdP GhcRn)
psb_ext :: XPSB GhcRn GhcRn
psb_ext :: forall idL idR. PatSynBind idL idR -> XPSB idL idR
psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_args :: forall idL idR.
PatSynBind idL idR -> HsPatSynDetails (Located (IdP idR))
psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_dir :: forall idL idR. PatSynBind idL idR -> HsPatSynDir idR
..} -> XPSB GhcRn GhcRn
UniqSet Name
psb_ext
  HsBindLR GhcRn GhcRn
_ -> UniqSet Name
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 GhcRn -> EnvReader (Maybe (HsExpr GhcRn))
hsDoCase (Ghc.HsDo XDo GhcRn
x HsStmtContext Name
ctx Located [GuardLStmt GhcRn]
lStmts) = do
  (Located [GuardLStmt GhcRn]
stmtsRes, VarSet
_) <- WriterT VarSet EnvReader (Located [GuardLStmt GhcRn])
-> EnvReader (Located [GuardLStmt GhcRn], VarSet)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT (WriterT VarSet EnvReader (Located [GuardLStmt GhcRn])
 -> EnvReader (Located [GuardLStmt GhcRn], VarSet))
-> WriterT VarSet EnvReader (Located [GuardLStmt GhcRn])
-> EnvReader (Located [GuardLStmt GhcRn], VarSet)
forall a b. (a -> b) -> a -> b
$ Located [GuardLStmt GhcRn]
-> ([GuardLStmt GhcRn]
    -> WriterT VarSet EnvReader [GuardLStmt GhcRn])
-> WriterT VarSet EnvReader (Located [GuardLStmt GhcRn])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Located [GuardLStmt GhcRn]
lStmts [GuardLStmt GhcRn] -> WriterT VarSet EnvReader [GuardLStmt GhcRn]
forall body.
(Data body, Data (Stmt GhcRn body)) =>
[LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
dealWithStatements
  Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn)))
-> (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn
-> EnvReader (Maybe (HsExpr GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> EnvReader (Maybe (HsExpr GhcRn)))
-> HsExpr GhcRn -> EnvReader (Maybe (HsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ XDo GhcRn
-> HsStmtContext Name -> Located [GuardLStmt GhcRn] -> HsExpr GhcRn
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
Ghc.HsDo XDo GhcRn
x HsStmtContext Name
ctx Located [GuardLStmt GhcRn]
stmtsRes
hsDoCase HsExpr GhcRn
_ = Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HsExpr GhcRn)
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 :: [LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
dealWithStatements [] = [LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
dealWithStatements (LStmt GhcRn body
lstmt : [LStmt GhcRn body]
xs) = do
  (LStmt GhcRn body
stmtRes, VarSet
names) <- WriterT VarSet EnvReader (LStmt GhcRn body)
-> WriterT VarSet EnvReader (LStmt GhcRn body, VarSet)
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
listen (WriterT VarSet EnvReader (LStmt GhcRn body)
 -> WriterT VarSet EnvReader (LStmt GhcRn body, VarSet))
-> WriterT VarSet EnvReader (LStmt GhcRn body)
-> WriterT VarSet EnvReader (LStmt GhcRn body, VarSet)
forall a b. (a -> b) -> a -> b
$ (Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body))
-> LStmt GhcRn body -> WriterT VarSet EnvReader (LStmt GhcRn body)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
forall body.
(Data (Stmt GhcRn body), Data body) =>
Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
dealWithStmt LStmt GhcRn body
lstmt
  (LStmt GhcRn body
stmtRes LStmt GhcRn body -> [LStmt GhcRn body] -> [LStmt GhcRn body]
forall a. a -> [a] -> [a]
:) ([LStmt GhcRn body] -> [LStmt GhcRn body])
-> WriterT VarSet EnvReader [LStmt GhcRn body]
-> WriterT VarSet EnvReader [LStmt GhcRn body]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterT Any (ReaderT Env TcM) ([LStmt GhcRn body], VarSet)
 -> WriterT Any (ReaderT Env TcM) ([LStmt GhcRn body], VarSet))
-> WriterT VarSet EnvReader [LStmt GhcRn body]
-> WriterT VarSet EnvReader [LStmt GhcRn body]
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 (VarSet
-> WriterT Any (ReaderT Env TcM) ([LStmt GhcRn body], VarSet)
-> WriterT Any (ReaderT Env TcM) ([LStmt GhcRn body], VarSet)
forall a. VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names) ([LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
forall body.
(Data body, Data (Stmt GhcRn body)) =>
[LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
dealWithStatements [LStmt GhcRn 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 :: Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
dealWithStmt = \case
  Ghc.BindStmt' XBindStmt GhcRn GhcRn body
x LPat GhcRn
lpat body
body SyntaxExpr GhcRn
bindExpr SyntaxExpr GhcRn
failExpr -> do
    let names :: VarSet
names = LPat GhcRn -> VarSet
extractVarPats LPat GhcRn
lpat
    VarSet -> WriterT VarSet EnvReader ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell VarSet
names
    body
bodyRes <- WriterT Any (ReaderT Env TcM) body -> WriterT VarSet EnvReader body
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT Any (ReaderT Env TcM) body
 -> WriterT VarSet EnvReader body)
-> WriterT Any (ReaderT Env TcM) body
-> WriterT VarSet EnvReader body
forall a b. (a -> b) -> a -> b
$ body -> WriterT Any (ReaderT Env TcM) body
forall a. Data a => a -> EnvReader a
recurse body
body
    Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body))
-> Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcRn GhcRn body
-> LPat GhcRn
-> body
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> Stmt GhcRn body
forall body.
XBindStmt GhcRn GhcRn body
-> LPat GhcRn
-> body
-> SyntaxExpr GhcRn
-> SyntaxExpr GhcRn
-> Stmt GhcRn body
Ghc.BindStmt' XBindStmt GhcRn GhcRn body
x LPat GhcRn
lpat body
bodyRes SyntaxExpr GhcRn
bindExpr SyntaxExpr GhcRn
failExpr

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

  Ghc.ApplicativeStmt XApplicativeStmt GhcRn GhcRn body
x [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs Maybe (SyntaxExpr GhcRn)
mbJoin -> do
    let dealWithAppArg :: ApplicativeArg GhcRn
-> WriterT VarSet EnvReader (ApplicativeArg GhcRn)
dealWithAppArg = \case
          a :: ApplicativeArg GhcRn
a@Ghc.ApplicativeArgOne{Bool
SyntaxExpr GhcRn
LPat GhcRn
XApplicativeArgOne GhcRn
LHsExpr GhcRn
xarg_app_arg_one :: forall idL. ApplicativeArg idL -> XApplicativeArgOne idL
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
fail_operator :: forall idL. ApplicativeArg idL -> SyntaxExpr idL
fail_operator :: SyntaxExpr GhcRn
is_body_stmt :: Bool
arg_expr :: LHsExpr GhcRn
app_arg_pattern :: LPat GhcRn
xarg_app_arg_one :: XApplicativeArgOne GhcRn
..} -> do
            VarSet -> WriterT VarSet EnvReader ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (VarSet -> WriterT VarSet EnvReader ())
-> VarSet -> WriterT VarSet EnvReader ()
forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> VarSet
extractVarPats LPat GhcRn
app_arg_pattern
            ApplicativeArg GhcRn
-> WriterT VarSet EnvReader (ApplicativeArg GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ApplicativeArg GhcRn
a
          a :: ApplicativeArg GhcRn
a@Ghc.ApplicativeArgMany{[GuardLStmt GhcRn]
HsExpr GhcRn
LPat GhcRn
XApplicativeArgMany GhcRn
xarg_app_arg_many :: forall idL. ApplicativeArg idL -> XApplicativeArgMany idL
app_stmts :: forall idL. ApplicativeArg idL -> [ExprLStmt idL]
final_expr :: forall idL. ApplicativeArg idL -> HsExpr idL
bv_pattern :: forall idL. ApplicativeArg idL -> LPat idL
bv_pattern :: LPat GhcRn
final_expr :: HsExpr GhcRn
app_stmts :: [GuardLStmt GhcRn]
xarg_app_arg_many :: XApplicativeArgMany GhcRn
..} -> do
            VarSet -> WriterT VarSet EnvReader ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (VarSet -> WriterT VarSet EnvReader ())
-> VarSet -> WriterT VarSet EnvReader ()
forall a b. (a -> b) -> a -> b
$ LPat GhcRn -> VarSet
extractVarPats LPat GhcRn
bv_pattern
            ([GuardLStmt GhcRn]
stmtsRes, VarSet
_) <- EnvReader ([GuardLStmt GhcRn], VarSet)
-> WriterT VarSet EnvReader ([GuardLStmt GhcRn], VarSet)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EnvReader ([GuardLStmt GhcRn], VarSet)
 -> WriterT VarSet EnvReader ([GuardLStmt GhcRn], VarSet))
-> (WriterT VarSet EnvReader [GuardLStmt GhcRn]
    -> EnvReader ([GuardLStmt GhcRn], VarSet))
-> WriterT VarSet EnvReader [GuardLStmt GhcRn]
-> WriterT VarSet EnvReader ([GuardLStmt GhcRn], VarSet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT VarSet EnvReader [GuardLStmt GhcRn]
-> EnvReader ([GuardLStmt GhcRn], VarSet)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT (WriterT VarSet EnvReader [GuardLStmt GhcRn]
 -> WriterT VarSet EnvReader ([GuardLStmt GhcRn], VarSet))
-> WriterT VarSet EnvReader [GuardLStmt GhcRn]
-> WriterT VarSet EnvReader ([GuardLStmt GhcRn], VarSet)
forall a b. (a -> b) -> a -> b
$ [GuardLStmt GhcRn] -> WriterT VarSet EnvReader [GuardLStmt GhcRn]
forall body.
(Data body, Data (Stmt GhcRn body)) =>
[LStmt GhcRn body] -> WriterT VarSet EnvReader [LStmt GhcRn body]
dealWithStatements [GuardLStmt GhcRn]
app_stmts
            ApplicativeArg GhcRn
-> WriterT VarSet EnvReader (ApplicativeArg GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ApplicativeArg GhcRn
a {app_stmts :: [GuardLStmt GhcRn]
Ghc.app_stmts = [GuardLStmt GhcRn]
stmtsRes}
#if !MIN_VERSION_ghc(9,0,0)
          ApplicativeArg GhcRn
a -> EnvReader (ApplicativeArg GhcRn)
-> WriterT VarSet EnvReader (ApplicativeArg GhcRn)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EnvReader (ApplicativeArg GhcRn)
 -> WriterT VarSet EnvReader (ApplicativeArg GhcRn))
-> EnvReader (ApplicativeArg GhcRn)
-> WriterT VarSet EnvReader (ApplicativeArg GhcRn)
forall a b. (a -> b) -> a -> b
$ (forall a. Data a => a -> EnvReader a)
-> ApplicativeArg GhcRn -> EnvReader (ApplicativeArg GhcRn)
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 ApplicativeArg GhcRn
a
#endif
    [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairsRes <- (((SyntaxExpr GhcRn, ApplicativeArg GhcRn)
 -> WriterT
      VarSet EnvReader (SyntaxExpr GhcRn, ApplicativeArg GhcRn))
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> WriterT
     VarSet EnvReader [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((SyntaxExpr GhcRn, ApplicativeArg GhcRn)
  -> WriterT
       VarSet EnvReader (SyntaxExpr GhcRn, ApplicativeArg GhcRn))
 -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
 -> WriterT
      VarSet EnvReader [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)])
-> ((ApplicativeArg GhcRn
     -> WriterT VarSet EnvReader (ApplicativeArg GhcRn))
    -> (SyntaxExpr GhcRn, ApplicativeArg GhcRn)
    -> WriterT
         VarSet EnvReader (SyntaxExpr GhcRn, ApplicativeArg GhcRn))
-> (ApplicativeArg GhcRn
    -> WriterT VarSet EnvReader (ApplicativeArg GhcRn))
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> WriterT
     VarSet EnvReader [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ApplicativeArg GhcRn
 -> WriterT VarSet EnvReader (ApplicativeArg GhcRn))
-> (SyntaxExpr GhcRn, ApplicativeArg GhcRn)
-> WriterT
     VarSet EnvReader (SyntaxExpr GhcRn, ApplicativeArg GhcRn)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) ApplicativeArg GhcRn
-> WriterT VarSet EnvReader (ApplicativeArg GhcRn)
dealWithAppArg [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairs
    Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body))
-> Stmt GhcRn body -> WriterT VarSet EnvReader (Stmt GhcRn body)
forall a b. (a -> b) -> a -> b
$ XApplicativeStmt GhcRn GhcRn body
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> Maybe (SyntaxExpr GhcRn)
-> Stmt GhcRn body
forall idL idR body.
XApplicativeStmt idL idR body
-> [(SyntaxExpr idR, ApplicativeArg idL)]
-> Maybe (SyntaxExpr idR)
-> StmtLR idL idR body
Ghc.ApplicativeStmt XApplicativeStmt GhcRn GhcRn body
x [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
pairsRes Maybe (SyntaxExpr GhcRn)
mbJoin

  Stmt GhcRn body
other -> EnvReader (Stmt GhcRn body)
-> WriterT VarSet EnvReader (Stmt GhcRn body)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EnvReader (Stmt GhcRn body)
 -> WriterT VarSet EnvReader (Stmt GhcRn body))
-> EnvReader (Stmt GhcRn body)
-> WriterT VarSet EnvReader (Stmt GhcRn body)
forall a b. (a -> b) -> a -> b
$ (forall a. Data a => a -> EnvReader a)
-> Stmt GhcRn body -> EnvReader (Stmt GhcRn body)
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 GhcRn body
other

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

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

          HsCmd GhcRn
_ -> MaybeT EnvReader (HsCmd GhcRn)
forall (f :: * -> *) a. Alternative f => f a
empty -- TODO what other cases should be handled?

        HsCmdTop GhcRn -> MaybeT EnvReader (HsCmdTop GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsCmdTop GhcRn -> MaybeT EnvReader (HsCmdTop GhcRn))
-> HsCmdTop GhcRn -> MaybeT EnvReader (HsCmdTop GhcRn)
forall a b. (a -> b) -> a -> b
$ XCmdTop GhcRn -> LHsCmd GhcRn -> HsCmdTop GhcRn
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
Ghc.HsCmdTop XCmdTop GhcRn
x2 LHsCmd GhcRn
cmdRes
#if !MIN_VERSION_ghc(9,0,0)
      HsCmdTop GhcRn
_ -> MaybeT EnvReader (HsCmdTop GhcRn)
forall (f :: * -> *) a. Alternative f => f a
empty
#endif
    HsExpr GhcRn -> MaybeT EnvReader (HsExpr GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsExpr GhcRn -> MaybeT EnvReader (HsExpr GhcRn))
-> HsExpr GhcRn -> MaybeT EnvReader (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XProc GhcRn -> LPat GhcRn -> LHsCmdTop GhcRn -> HsExpr GhcRn
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
Ghc.HsProc XProc GhcRn
x1 LPat GhcRn
lpat LHsCmdTop GhcRn
cmdTopRes
hsProcCase HsExpr GhcRn
_ = Maybe (HsExpr GhcRn) -> EnvReader (Maybe (HsExpr GhcRn))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing

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

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

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

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

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

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

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

addScopedVars :: VarSet -> EnvReader a -> EnvReader a
addScopedVars :: VarSet -> EnvReader a -> EnvReader a
addScopedVars VarSet
names = (ReaderT Env TcM (a, Any) -> ReaderT Env TcM (a, Any))
-> EnvReader a -> EnvReader a
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 ((ReaderT Env TcM (a, Any) -> ReaderT Env TcM (a, Any))
 -> EnvReader a -> EnvReader a)
-> (ReaderT Env TcM (a, Any) -> ReaderT Env TcM (a, Any))
-> EnvReader a
-> EnvReader a
forall a b. (a -> b) -> a -> b
$ (Env -> Env)
-> ReaderT Env TcM (a, Any) -> ReaderT Env TcM (a, Any)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((VarSet -> VarSet) -> Env -> Env
overVarSet (VarSet
names VarSet -> VarSet -> VarSet
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 GhcRn, [Name], UniqSet Name)]
-> [(RecFlag, Bag (LHsBind GhcRn))]
depAnalBinds [(LHsBind GhcRn, [Name], UniqSet Name)]
binds_w_dus
  = (SCC (LHsBind GhcRn, [Name], UniqSet Name)
 -> (RecFlag, Bag (LHsBind GhcRn)))
-> [SCC (LHsBind GhcRn, [Name], UniqSet Name)]
-> [(RecFlag, Bag (LHsBind GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map SCC (LHsBind GhcRn, [Name], UniqSet Name)
-> (RecFlag, Bag (LHsBind GhcRn))
forall a b c. SCC (a, b, c) -> (RecFlag, Bag a)
get_binds [SCC (LHsBind GhcRn, [Name], UniqSet Name)]
sccs
  where
    sccs :: [SCC (LHsBind GhcRn, [Name], UniqSet Name)]
sccs = ((LHsBind GhcRn, [Name], UniqSet Name) -> [Name])
-> ((LHsBind GhcRn, [Name], UniqSet Name) -> [Name])
-> [(LHsBind GhcRn, [Name], UniqSet Name)]
-> [SCC (LHsBind GhcRn, [Name], UniqSet Name)]
forall node.
(node -> [Name]) -> (node -> [Name]) -> [node] -> [SCC node]
Ghc.depAnal
             (\(LHsBind GhcRn
_, [Name]
defs, UniqSet Name
_) -> [Name]
defs)
             (\(LHsBind GhcRn
_, [Name]
_, UniqSet Name
uses) -> UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
Ghc.nonDetEltsUniqSet UniqSet Name
uses)
             [(LHsBind GhcRn, [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, a -> Bag a
forall a. a -> Bag a
Ghc.unitBag a
bind)
    get_binds (Graph.CyclicSCC  [(a, b, c)]
binds_w_dus') =
      (RecFlag
Ghc.Recursive, [a] -> Bag a
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 = TcPlugin :: forall s.
TcPluginM s
-> (s -> TcPluginSolver) -> (s -> TcPluginM ()) -> TcPlugin
Ghc.TcPlugin
  { tcPluginInit :: TcPluginM TcPluginNames
Ghc.tcPluginInit  = TcPluginM TcPluginNames
initTcPlugin
  , tcPluginSolve :: TcPluginNames -> TcPluginSolver
Ghc.tcPluginSolve = TcPluginNames -> TcPluginSolver
solver
  , tcPluginStop :: TcPluginNames -> TcPluginM ()
Ghc.tcPluginStop = TcPluginM () -> TcPluginNames -> TcPluginM ()
forall a b. a -> b -> a
const (TcPluginM () -> TcPluginNames -> TcPluginM ())
-> TcPluginM () -> TcPluginNames -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ () -> TcPluginM ()
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 (Name -> TcPluginM Class) -> TcPluginM Name -> TcPluginM Class
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 (Name -> TcPluginM Class) -> TcPluginM Name -> TcPluginM Class
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 (Name -> TcPluginM TyCon) -> TcPluginM Name -> TcPluginM TyCon
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")

  TcPluginNames -> TcPluginM TcPluginNames
forall (f :: * -> *) a. Applicative f => a -> f a
pure MkTcPluginNames :: Name -> Class -> Class -> TyCon -> TcPluginNames
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_ev :: Ct -> CtEvidence
cc_class :: Ct -> Class
cc_tyargs :: Ct -> [Type]
cc_pend_sc :: Ct -> Bool
cc_pend_sc :: Bool
cc_tyargs :: [Type]
cc_class :: Class
cc_ev :: CtEvidence
..} <- Ct
ct
  , TcPluginNames -> Name
showLevClassName TcPluginNames
names Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Class -> Name
forall a. NamedThing a => a -> Name
Ghc.getName Class
cc_class
  , [Ghc.TyConApp TyCon
tyCon [], Type
arg2] <- [Type]
cc_tyargs
  = Either (Type, Ct) (Type, Ct)
-> Maybe (Either (Type, Ct) (Type, Ct))
forall a. a -> Maybe a
Just (Either (Type, Ct) (Type, Ct)
 -> Maybe (Either (Type, Ct) (Type, Ct)))
-> Either (Type, Ct) (Type, Ct)
-> Maybe (Either (Type, Ct) (Type, Ct))
forall a b. (a -> b) -> a -> b
$ if TyCon -> Name
forall a. NamedThing a => a -> Name
Ghc.getName TyCon
tyCon Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
Ghc.liftedRepName
       then (Type, Ct) -> Either (Type, Ct) (Type, Ct)
forall a b. b -> Either a b
Right (Type
arg2, Ct
ct)
       else (Type, Ct) -> Either (Type, Ct) (Type, Ct)
forall a b. a -> Either a b
Left (Type
arg2, Ct
ct)
  | Bool
otherwise = Maybe (Either (Type, Ct) (Type, Ct))
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 <- [Either (Type, Ct) (Type, Ct)]
-> (Either (Type, Ct) (Type, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> TcPluginM [Maybe (EvTerm, Ct)]
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 (Ct -> Maybe (Either (Type, Ct) (Type, Ct)))
-> [Ct] -> [Either (Type, Ct) (Type, Ct)]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [Ct]
wanted) ((Either (Type, Ct) (Type, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
 -> TcPluginM [Maybe (EvTerm, Ct)])
-> (Either (Type, Ct) (Type, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> TcPluginM [Maybe (EvTerm, Ct)]
forall a b. (a -> b) -> a -> b
$ \case
    Left (Type
ty, Ct
ct) -> do -- unlifted type
      EvTerm
unshowableDict <- TcM EvTerm -> TcPluginM EvTerm
forall a. TcM a -> TcPluginM a
Ghc.unsafeTcPluginTcM (TcM EvTerm -> TcPluginM EvTerm) -> TcM EvTerm -> TcPluginM EvTerm
forall a b. (a -> b) -> a -> b
$ Type -> TcM EvTerm
buildUnshowableDict Type
ty
      Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a b. (a -> b) -> a -> b
$ (EvTerm, Ct) -> Maybe (EvTerm, Ct)
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]
      Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct)))
-> Maybe (EvTerm, Ct) -> TcPluginM (Maybe (EvTerm, Ct))
forall a b. (a -> b) -> a -> b
$ Maybe EvTerm
mShowDict Maybe EvTerm -> (EvTerm -> (EvTerm, Ct)) -> Maybe (EvTerm, Ct)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \EvTerm
showDict ->
        let (ClsInst
succInst, [Type]
_) = (ClsInst, [Type])
-> Either SDoc (ClsInst, [Type]) -> (ClsInst, [Type])
forall b a. b -> Either a b -> b
fromRight (String -> (ClsInst, [Type])
forall a. HasCallStack => String -> a
error String
"impossible: no Succeed instance") (Either SDoc (ClsInst, [Type]) -> (ClsInst, [Type]))
-> Either SDoc (ClsInst, [Type]) -> (ClsInst, [Type])
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)
  TcPluginResult -> TcPluginM TcPluginResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcPluginResult -> TcPluginM TcPluginResult)
-> TcPluginResult -> TcPluginM TcPluginResult
forall a b. (a -> b) -> a -> b
$ [(EvTerm, Ct)] -> [Ct] -> TcPluginResult
Ghc.TcPluginOk ([Maybe (EvTerm, Ct)] -> [(EvTerm, Ct)]
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 :: Id
dfun = ClsInst -> Id
Ghc.is_dfun ClsInst
clsInst
          ([Id]
vars, [Type]
subclasses, Type
inst) = Type -> ([Id], [Type], Type)
Ghc.tcSplitSigmaTy (Type -> ([Id], [Type], Type)) -> Type -> ([Id], [Type], Type)
forall a b. (a -> b) -> a -> b
$ Id -> Type
Ghc.idType Id
dfun
      if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
subclasses
         then Maybe EvTerm -> TcPluginM (Maybe EvTerm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EvTerm -> TcPluginM (Maybe EvTerm))
-> (EvTerm -> Maybe EvTerm) -> EvTerm -> TcPluginM (Maybe EvTerm)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvTerm -> Maybe EvTerm
forall a. a -> Maybe a
Just (EvTerm -> TcPluginM (Maybe EvTerm))
-> EvTerm -> TcPluginM (Maybe EvTerm)
forall a b. (a -> b) -> a -> b
$ Id -> [Type] -> [EvExpr] -> EvTerm
Ghc.evDFunApp Id
dfun [] [] -- why no use of vars here?
         else do
           let tyVarMap :: Map Id Type
tyVarMap = Type -> [Type] -> Map Id Type
mkTyVarMapping Type
inst [Type]
tys
           Maybe [EvTerm]
mSolvedSubClassDicts <- ([Maybe EvTerm] -> Maybe [EvTerm])
-> TcPluginM [Maybe EvTerm] -> TcPluginM (Maybe [EvTerm])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe EvTerm] -> Maybe [EvTerm]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (TcPluginM [Maybe EvTerm] -> TcPluginM (Maybe [EvTerm]))
-> ((Type -> TcPluginM (Maybe EvTerm)) -> TcPluginM [Maybe EvTerm])
-> (Type -> TcPluginM (Maybe EvTerm))
-> TcPluginM (Maybe [EvTerm])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type]
-> (Type -> TcPluginM (Maybe EvTerm)) -> TcPluginM [Maybe EvTerm]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Type]
subclasses ((Type -> TcPluginM (Maybe EvTerm)) -> TcPluginM (Maybe [EvTerm]))
-> (Type -> TcPluginM (Maybe EvTerm)) -> TcPluginM (Maybe [EvTerm])
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 Id Type -> [Type] -> [Type]
instantiateVars Map Id Type
tyVarMap [Type]
subTys
             TcPluginNames -> Class -> [Type] -> TcPluginM (Maybe EvTerm)
buildDict TcPluginNames
names Class
subCls [Type]
subTys'
           Maybe EvTerm -> TcPluginM (Maybe EvTerm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EvTerm -> TcPluginM (Maybe EvTerm))
-> Maybe EvTerm -> TcPluginM (Maybe EvTerm)
forall a b. (a -> b) -> a -> b
$ do
             [Type]
vars' <- (Id -> Maybe Type) -> [Id] -> Maybe [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Id Type
tyVarMap Map Id Type -> Id -> Maybe Type
forall k a. Ord k => Map k a -> k -> Maybe a
M.!?) [Id]
vars
             Id -> [Type] -> [EvExpr] -> EvTerm
Ghc.evDFunApp Id
dfun [Type]
vars' ([EvExpr] -> EvTerm)
-> ([EvTerm] -> [EvExpr]) -> [EvTerm] -> EvTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvTerm -> EvExpr) -> [EvTerm] -> [EvExpr]
forall a b. (a -> b) -> [a] -> [b]
map EvTerm -> EvExpr
getEvExprFromDict
               ([EvTerm] -> EvTerm) -> Maybe [EvTerm] -> Maybe EvTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [EvTerm]
mSolvedSubClassDicts
    Left SDoc
_
      | Class
cls Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== TcPluginNames -> Class
showClass TcPluginNames
names
      , [Type
ty] <- [Type]
tys -> do
          EvTerm
unshowableDict <- TcM EvTerm -> TcPluginM EvTerm
forall a. TcM a -> TcPluginM a
Ghc.unsafeTcPluginTcM (TcM EvTerm -> TcPluginM EvTerm) -> TcM EvTerm -> TcPluginM EvTerm
forall a b. (a -> b) -> a -> b
$ Type -> TcM EvTerm
buildUnshowableDict Type
ty
          let (ClsInst
inst, [Type]
_) = (ClsInst, [Type])
-> Either SDoc (ClsInst, [Type]) -> (ClsInst, [Type])
forall b a. b -> Either a b -> b
fromRight (String -> (ClsInst, [Type])
forall a. HasCallStack => String -> a
error String
"impossible: no Show instance for ShowWrapper") (Either SDoc (ClsInst, [Type]) -> (ClsInst, [Type]))
-> Either SDoc (ClsInst, [Type]) -> (ClsInst, [Type])
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)
          Maybe EvTerm -> TcPluginM (Maybe EvTerm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EvTerm -> TcPluginM (Maybe EvTerm))
-> Maybe EvTerm -> TcPluginM (Maybe EvTerm)
forall a b. (a -> b) -> a -> b
$ EvTerm -> Maybe EvTerm
forall a. a -> Maybe a
Just EvTerm
liftedDict
      | Bool
otherwise -> Maybe EvTerm -> TcPluginM (Maybe EvTerm)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EvTerm
forall a. Maybe a
Nothing

getEvExprFromDict :: Ghc.EvTerm -> Ghc.EvExpr
getEvExprFromDict :: EvTerm -> EvExpr
getEvExprFromDict = \case
  Ghc.EvExpr EvExpr
expr -> EvExpr
expr
  EvTerm
_ -> String -> EvExpr
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 Id Type
mkTyVarMapping Type
wanted [Type]
tys =
  let wantedHead :: [Type]
wantedHead = (Type, [Type]) -> [Type]
forall a b. (a, b) -> b
snd ((Type, [Type]) -> [Type]) -> (Type, [Type]) -> [Type]
forall a b. (a -> b) -> a -> b
$ Type -> (Type, [Type])
Ghc.splitAppTys Type
wanted
      wantedTyVars :: [Type]
wantedTyVars = (Type -> [Type]) -> [Type] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Type, [Type]) -> [Type]
forall a b. (a, b) -> b
snd ((Type, [Type]) -> [Type])
-> (Type -> (Type, [Type])) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Type, [Type])
Ghc.splitAppTys) [Type]
wantedHead
      concreteTys :: [Type]
concreteTys = (Type -> [Type]) -> [Type] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Type, [Type]) -> [Type]
forall a b. (a, b) -> b
snd ((Type, [Type]) -> [Type])
-> (Type -> (Type, [Type])) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Type, [Type])
Ghc.splitAppTys) [Type]
tys
   in [(Id, Type)] -> Map Id Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Id, Type)] -> Map Id Type) -> [(Id, Type)] -> Map Id Type
forall a b. (a -> b) -> a -> b
$ do
     (Type
a, Type
b) <- [Type] -> [Type] -> [(Type, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
wantedTyVars [Type]
concreteTys
     Just Id
tyVar <- [Type -> Maybe Id
Ghc.getTyVar_maybe Type
a]
     (Id, Type) -> [(Id, Type)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id
tyVar, Type
b)

instantiateVars :: M.Map Ghc.TyVar Ghc.Type -> [Ghc.Type] -> [Ghc.Type]
instantiateVars :: Map Id Type -> [Type] -> [Type]
instantiateVars Map Id Type
tyVarMap [Type]
tys = Type -> Type
replace (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tys
  where
    replace :: Type -> Type
replace Type
arg = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
arg (Maybe Type -> Type) -> Maybe Type -> Type
forall a b. (a -> b) -> a -> b
$ do
      Id
tyVar <- Type -> Maybe Id
Ghc.getTyVar_maybe Type
arg
      Id -> Map Id Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Id
tyVar Map Id 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' (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
Ghc.pprTypeForUser' Type
ty
  EvExpr
str <- String -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr
forall (m :: * -> *). MonadThings m => String -> m EvExpr
Ghc.mkStringExpr (String -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr)
-> String -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr
forall a b. (a -> b) -> a -> b
$ String
"<" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tyString String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">"
  EvTerm -> TcM EvTerm
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvTerm -> TcM EvTerm)
-> (EvExpr -> EvTerm) -> EvExpr -> TcM EvTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvExpr -> EvTerm
Ghc.EvExpr (EvExpr -> TcM EvTerm) -> EvExpr -> TcM EvTerm
forall a b. (a -> b) -> a -> b
$
    [Id] -> EvExpr -> EvExpr
Ghc.mkCoreLams [Type -> Id
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 = Id -> [Type] -> [EvExpr] -> EvTerm
Ghc.evDFunApp (ClsInst -> Id
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 = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
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 i = show $ I8# i

instance ShowLev 'Exts.Int16Rep Exts.Int16# where
  showLev i = show $ I16# i

instance ShowLev 'Exts.Int32Rep Exts.Int32# where
  showLev i = show $ I32# 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 = Word -> String
forall a. Show a => a -> String
show (Word -> String) -> Word -> String
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 w = show $ W8# w

instance ShowLev 'Exts.Word16Rep Exts.Word16# where
  showLev w = show $ W16# w

instance ShowLev 'Exts.Word32Rep Exts.Word32# where
  showLev w = show $ W32# 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 = Float -> String
forall a. Show a => a -> String
show (Float -> String) -> Float -> String
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 = Double -> String
forall a. Show a => a -> String
show (Double -> String) -> Double -> String
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) = a -> String
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 = a -> String
forall a. Show a => a -> String
show