{-# LANGUAGE DataKinds #-} -- for 9.0
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.DeepSeq (force)
import           Control.Monad.IO.Class
import           Data.Char (isSpace)
import           Data.Foldable
import           Data.Functor
import qualified Data.List as L
import qualified Data.Map.Lazy as M
import           Data.Maybe
import qualified Data.Text.Lazy as T
import           Debug.Trace (trace, traceIO, traceM)
import qualified GHC.Exts as Exts
import           GHC.Int
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.Renamer as Renamer
import qualified Debug.Breakpoint.TimerManager as TM
import qualified Debug.Breakpoint.TypeChecker as TypeChecker

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

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

-- re-exported to avoid requiring the client to depend on the containers package
fromAscList :: Ord k => [(k, v)] -> M.Map k v
fromAscList :: forall k v. Ord k => [(k, v)] -> Map k v
fromAscList = forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList

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

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

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

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

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

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

usePrettyPrinting :: IO Bool
usePrettyPrinting :: IO Bool
usePrettyPrinting = forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"NO_PRETTY_PRINT"

color :: (?useColor :: Bool) => String -> String -> String
color :: (?useColor::Bool) => String -> String -> String
color String
c String
s =
  if ?useColor::Bool
?useColor
     then String
"\ESC[" forall a. Semigroup a => a -> a -> a
<> String
c forall a. Semigroup a => a -> a -> a
<> String
"m\STX" forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"\ESC[m\STX"
     else String
s

red, green, grey, cyan :: String
red :: String
red = String
"31"
green :: String
green = String
"32"
grey :: String
grey = String
"37"
cyan :: String
cyan = String
"36"

printVars :: (?useColor :: Bool, ?prettyPrint :: Bool)
          => M.Map String String -> String
printVars :: (?useColor::Bool, ?prettyPrint::Bool) =>
Map String String -> String
printVars Map String String
vars =
  let eqSign :: String
eqSign | ?prettyPrint::Bool
?prettyPrint = String
" =\n"
             | Bool
otherwise = String
" = "
      mkLine :: (String, String) -> String
mkLine (String
k, String
v) = (?useColor::Bool) => String -> String -> String
color String
cyan (String
k forall a. Semigroup a => a -> a -> a
<> String
eqSign) forall a. Semigroup a => a -> a -> a
<> (?prettyPrint::Bool) => String -> String
prettify String
v
   in [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
L.intersperse String
"" forall a b. (a -> b) -> a -> b
$ (?useColor::Bool, ?prettyPrint::Bool) => (String, String) -> String
mkLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map String String
vars

-- TODO don't apply parsing to things inside angle brackets
prettify :: (?prettyPrint :: Bool) => String -> String
prettify :: (?prettyPrint::Bool) => String -> String
prettify =
  if ?prettyPrint::Bool
?prettyPrint
  then Text -> String
T.unpack
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputOptions -> String -> Text
PS.pStringOpt
         OutputOptions
PS.defaultOutputOptionsDarkBg
           { outputOptionsInitialIndent :: Int
PS.outputOptionsInitialIndent = Int
2
           , outputOptionsIndentAmount :: Int
PS.outputOptionsIndentAmount = Int
2
           , outputOptionsColorOptions :: Maybe ColorOptions
PS.outputOptionsColorOptions = forall a. a -> Maybe a
Just PS.ColorOptions
             { colorQuote :: Style
PS.colorQuote = Style
PS.colorNull
             , colorString :: Style
PS.colorString = Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Blue
             , colorError :: Style
PS.colorError = Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Red
             , colorNum :: Style
PS.colorNum = Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Green
             , colorRainbowParens :: [Style]
PS.colorRainbowParens = [Intensity -> Color -> Style
PS.colorBold Intensity
PS.Vivid Color
PS.Cyan]
             }
           }
  else forall a. a -> a
id

inactivePluginStr :: String
inactivePluginStr :: String
inactivePluginStr =
  String
"Cannot set breakpoint: the Debug.Trace plugin is not active"

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

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

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

-- | Similar to 'queryVars' but specialized to an 'IO' context. You should favor
-- this over 'queryVarsM' if a 'MonadIO' instance is available.
queryVarsIO :: MonadIO m => m ()
queryVarsIO :: forall (m :: * -> *). MonadIO m => m ()
queryVarsIO =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
traceIO String
inactivePluginStr)

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

-- | Sets a breakpoint in an 'IO' based 'Monad'. You should favor this over
-- 'breakpointM' if the monad can perform IO.
breakpointIO :: MonadIO m => m ()
breakpointIO :: forall (m :: * -> *). MonadIO m => m ()
breakpointIO =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
traceIO String
inactivePluginStr)

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

-- Use an "unsafe" foreign function to more or less stop the runtime.
foreign import ccall unsafe "stdio.h getchar" blockOnInput :: IO Int

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

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

plugin :: Ghc.Plugin
plugin :: Plugin
plugin = Plugin
Ghc.defaultPlugin
  { pluginRecompile :: [String] -> IO PluginRecompile
Ghc.pluginRecompile = [String] -> IO PluginRecompile
Ghc.purePlugin
  , renamedResultAction :: [String]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
Ghc.renamedResultAction = forall a b. a -> b -> a
const TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
Renamer.renameAction
  , tcPlugin :: TcPlugin
Ghc.tcPlugin = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TcPlugin
TypeChecker.tcPlugin
  }

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

-- | Levity polymorphic 'Show'
class ShowLev (rep :: Exts.RuntimeRep) (a :: Exts.TYPE rep) where
  showLev :: a -> String

instance ShowLev 'Exts.IntRep Exts.Int# where
  showLev :: Int# -> String
showLev Int#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int# -> Int
I# Int#
i

instance ShowLev 'Exts.Int8Rep Exts.Int8# where
  showLev :: Int8# -> String
showLev Int8#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int8# -> Int8
I8# Int8#
i

instance ShowLev 'Exts.Int16Rep Exts.Int16# where
  showLev :: Int16# -> String
showLev Int16#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int16# -> Int16
I16# Int16#
i

instance ShowLev 'Exts.Int32Rep Exts.Int32# where
  showLev :: Int32# -> String
showLev Int32#
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int32# -> Int32
I32# Int32#
i

#if MIN_VERSION_base(4,17,0)
instance ShowLev 'Exts.Int64Rep Exts.Int64# where
  showLev i = show $ I64# i
#endif

instance ShowLev 'Exts.WordRep Exts.Word# where
  showLev :: Word# -> String
showLev Word#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word# -> Word
W# Word#
w

instance ShowLev 'Exts.Word8Rep Exts.Word8# where
  showLev :: Word8# -> String
showLev Word8#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word8# -> Word8
W8# Word8#
w

instance ShowLev 'Exts.Word16Rep Exts.Word16# where
  showLev :: Word16# -> String
showLev Word16#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word16# -> Word16
W16# Word16#
w

instance ShowLev 'Exts.Word32Rep Exts.Word32# where
  showLev :: Word32# -> String
showLev Word32#
w = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Word32# -> Word32
W32# Word32#
w

#if MIN_VERSION_base(4,17,0)
instance ShowLev 'Exts.Word64Rep Exts.Word64# where
  showLev w = show $ W64# w
#endif

instance ShowLev 'Exts.FloatRep Exts.Float# where
  showLev :: Float# -> String
showLev Float#
f = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Float# -> Float
Exts.F# Float#
f

instance ShowLev 'Exts.DoubleRep Exts.Double# where
  showLev :: Double# -> String
showLev Double#
d = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double# -> Double
Exts.D# Double#
d

newtype ShowWrapper a = MkShowWrapper a

instance ShowLev Exts.LiftedRep a => Show (ShowWrapper a) where
  show :: ShowWrapper a -> String
show (MkShowWrapper a
a) = forall a. ShowLev LiftedRep a => a -> String
showLev a
a

class Succeed a where
  _succeed :: a -> String

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