{-# language AllowAmbiguousTypes #-}

-- | This module provides combinators for spawning heap console in convenient
-- way.
--
-- = Console usage
--
-- Console startup is indicated by a message:
--
-- @
-- [Entering heap-view - use `:help` for more information]
-- @
--
-- followed by console's prompt:
--
-- @
-- heap-console>
-- @
--
-- here you can probe for values of bindings or use provided commands - e.g.
-- when opening console with:
--
-- @
-- inspect (42, \'a\')
-- @
--
-- you can inspect given value under name @it@:
--
-- @
-- heap-console> it
-- (_, \'a\')
-- @
--
-- or see the value strictly evaluated (up to the configured depth):
--
-- @
-- heap-console> !it
-- (42, \'a\')
-- @
--
-- or you can access it's parts by using selection:
--
-- @
-- heap-console> it.1
-- \'a\'
-- @
--
-- __Bindings__ can be automatically created with functions like 'inspectD',
-- added in arbitrary places in program using e.g. 'evidenceD' or added in
-- console directly by assigning results of selections:
--
-- @
-- heap-console> foo = bar.0.baz
-- @
--
-- __Selections__ consist of sequence of dot-separated indexes, optionally
-- prefixed with @!@ to force thunks along the way. Valid indexes are:
--
-- * positive integer (e.g. @3@) - position of element in list, tuple or other
--   data constructor
--
-- * record field name (e.g. @foo@) - name of field in record (only works when
--   given enough information - that is, when value has 'Data' instance
--   available)
--
-- In general, it's recommended to prefer combinators suffixed with @D@ when
-- possible - they require 'Data' instance for bindings being added, but
-- provide ability to recover record syntax and information about unpacked
-- fields - in case of combinators without @D@, unpacked fields appear as plain
-- @Word#@s without any information about their origin and are not indexable.
-- 'Data' instances can be easily derived using @-XDeriveDataTypeable@.
module Heap.Console
  {-# warning
    "\"heap-console\" is meant for debugging only\
    \ - make sure you remove it in production."
  #-}
  ( inspect
  , inspectD
  , inspecting
  , inspectingD
  , inspectA
  , inspectAD
  , investigate
  , investigateD
  , inspection
  , withInspection
  , investigation
  , withEvidence
  , withEvidenceD
  , evidence
  , evidenceD
  ) where

import Control.Arrow hiding (first, second)
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.Char
import Data.Data
import Data.Function
import Data.Functor
import Data.IORef
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Foldable
import GHC.Exts.Heap
import GHC.Stack
import Heap.Console.Value
import System.Console.Haskeline
import System.IO.Unsafe
import Text.Read (readMaybe)

-- TODO: some persistent configuration?
-- TODO: implement auto-completion.

-------------------------------------------------------------------------------
-- | Opens console for inspecting argument before returning it. Argument is
-- provided in console under name @it@.
--
-- >>> inspect 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- 42
inspect :: a -> a
inspect :: a -> a
inspect = (a -> a -> a) -> a -> a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join a -> a -> a
forall a b. a -> b -> b
inspecting

-- | Version of 'inspect' providing more precise inspection using 'Data' -
-- prefer this one where possible.
--
-- >>> inspectD 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- 42
inspectD :: Data a => a -> a
inspectD :: a -> a
inspectD = (a -> a -> a) -> a -> a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join a -> a -> a
forall a b. Data a => a -> b -> b
inspectingD

-- | Opens console for inspecting @a@ before returning @b@. Argument @a@ is
-- provided in console under name @it@.
--
-- >>> inspecting 42 'a'
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- 'a'
inspecting :: a -> b -> b
inspecting :: a -> b -> b
inspecting = Either Box Value -> b -> b
forall b. Either Box Value -> b -> b
inspectingSome (Either Box Value -> b -> b)
-> (a -> Either Box Value) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> Either Box Value
forall a b. a -> Either a b
Left (Box -> Either Box Value) -> (a -> Box) -> a -> Either Box Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Box
forall a. a -> Box
asBox

-- | Version of 'inspecting' providing more precise inspection using 'Data' -
-- prefer this one where possible.
--
-- >>> inspectingD 42 'a'
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- 'a'
inspectingD :: Data a => a -> b -> b
inspectingD :: a -> b -> b
inspectingD = Either Box Value -> b -> b
forall b. Either Box Value -> b -> b
inspectingSome (Either Box Value -> b -> b)
-> (a -> Either Box Value) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either Box Value
forall a b. b -> Either a b
Right (Value -> Either Box Value)
-> (a -> Value) -> a -> Either Box Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. Data a => a -> Value
Value

inspectingSome :: Either Box Value -> b -> b
inspectingSome :: Either Box Value -> b -> b
inspectingSome Either Box Value
v = () -> b -> b
seq (() -> b -> b) -> () -> b -> b
forall a b. (a -> b) -> a -> b
$ IO () -> ()
forall a. IO a -> a
unsafePerformIO do
  Console
c <- IO Console
consoleWithEvidence
  Console -> IO ()
heapConsole Console
c{ consoleBinds :: Map String (Either Box Value)
consoleBinds = String
-> Either Box Value
-> Map String (Either Box Value)
-> Map String (Either Box Value)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
"it" Either Box Value
v (Map String (Either Box Value) -> Map String (Either Box Value))
-> Map String (Either Box Value) -> Map String (Either Box Value)
forall a b. (a -> b) -> a -> b
$ Console -> Map String (Either Box Value)
consoleBinds Console
c }
{-# noinline inspectingSome #-}

-- | Opens console for inspecting argument. Argument is provided in console
-- under name @it@.
--
-- >>> inspectA 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
inspectA :: Applicative f => a -> f ()
inspectA :: a -> f ()
inspectA a
a = a -> f () -> f ()
forall a b. a -> b -> b
inspecting a
a (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Version of 'inspectA' providing more precise inspection using 'Data' -
-- prefer this one where possible.
--
-- >>> inspectAD 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
inspectAD :: (Data a, Applicative f) => a -> f ()
inspectAD :: a -> f ()
inspectAD a
a = a -> f () -> f ()
forall a b. Data a => a -> b -> b
inspectingD a
a (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Opens console for inspecting argument before failing with error. Argument
-- is provided in console under name @it@.
--
-- >>> investigate 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- *** Exception: Heap.Console.investigate: closed investigation
-- CallStack (from HasCallStack):
--   investigate, called at <interactive>:1:1 in interactive:Ghci
investigate :: HasCallStack => a -> b
investigate :: a -> b
investigate a
a = (HasCallStack => b) -> b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => b) -> b) -> (HasCallStack => b) -> b
forall a b. (a -> b) -> a -> b
$ a -> b -> b
forall a b. a -> b -> b
inspecting a
a (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$
  String -> b
forall a. HasCallStack => String -> a
error String
"Heap.Console.investigate: closed investigation"

-- | Version of 'investigate' providing more precise inspection using 'Data' -
-- prefer this one where possible.
--
-- >>> investigateD 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- *** Exception: Heap.Console.investigateD: closed investigation
-- CallStack (from HasCallStack):
--   investigateD, called at <interactive>:1:1 in interactive:Ghci
investigateD :: (HasCallStack, Data a) => a -> b
investigateD :: a -> b
investigateD a
a = (HasCallStack => b) -> b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => b) -> b) -> (HasCallStack => b) -> b
forall a b. (a -> b) -> a -> b
$ a -> b -> b
forall a b. Data a => a -> b -> b
inspectingD a
a (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$
  String -> b
forall a. HasCallStack => String -> a
error String
"Heap.Console.investigateD: closed investigation"

-- | Opens console with recorded "evidence" in scope.
--
-- >>> inspection
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
inspection :: Applicative f => f ()
inspection :: f ()
inspection = f () -> f ()
forall a. a -> a
withInspection (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Opens console with recorded "evidence" in scope, before returning given
-- argument.
--
-- >>> withInspection 42
-- [Entering heap-view - use `:help` for more information]
-- ...
-- [Exiting heap-view]
-- 42
withInspection :: a -> a
withInspection :: a -> a
withInspection a
a =
  -- NOTE: do not eta reduce - GHC seems to memoize it as CAF in that case.
  IO () -> ()
forall a. IO a -> a
unsafePerformIO (Console -> IO ()
heapConsole (Console -> IO ()) -> IO Console -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Console
consoleWithEvidence) () -> a -> a
`seq` a
a
{-# noinline withInspection #-}

-- | Opens console with recorded "evidence" in scope before failing with error.
--
-- >>> investigation
-- [Entering heap-view - use `:help` for more information]
-- heap-console>
-- [Exiting heap-view]
-- *** Exception: Heap.Console.investigation: closed investigation
-- CallStack (from HasCallStack):
--   investigation, called at <interactive>:1:1 in interactive:Ghci
investigation :: HasCallStack => a
investigation :: a
investigation = (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. a -> a
withInspection (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
  String -> a
forall a. HasCallStack => String -> a
error String
"Heap.Console.investigation: closed investigation"

-- | Records @a@ as "evidence" to be later provided in console under given
-- name, before returning @b@.
--
-- >>> withEvidence "foo" 'a' inspection
-- [Entering heap-view - use `:help` for more information]
-- heap-console> foo
-- 'a'
-- ...
-- [Exiting heap-view]
withEvidence :: String -> a -> b -> b
withEvidence :: String -> a -> b -> b
withEvidence String
n = String -> Either Box Value -> b -> b
forall a. String -> Either Box Value -> a -> a
withSomeEvidence String
n (Either Box Value -> b -> b)
-> (a -> Either Box Value) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> Either Box Value
forall a b. a -> Either a b
Left (Box -> Either Box Value) -> (a -> Box) -> a -> Either Box Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Box
forall a. a -> Box
asBox

-- | Version of 'withEvidence' providing more precise inspection using 'Data' -
-- prefer this one where possible.
--
-- >>> withEvidenceD "foo" 'a' inspection
-- [Entering heap-view - use `:help` for more information]
-- heap-console> foo
-- 'a'
-- ...
-- [Exiting heap-view]
withEvidenceD :: Data a => String -> a -> b -> b
withEvidenceD :: String -> a -> b -> b
withEvidenceD String
n = String -> Either Box Value -> b -> b
forall a. String -> Either Box Value -> a -> a
withSomeEvidence String
n (Either Box Value -> b -> b)
-> (a -> Either Box Value) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either Box Value
forall a b. b -> Either a b
Right (Value -> Either Box Value)
-> (a -> Value) -> a -> Either Box Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. Data a => a -> Value
Value

-- | Records @a@ as "evidence" to be later provided in console under given
-- name.
--
-- >>> evidence "foo" 42
-- >>> inspection
-- [Entering heap-view - use `:help` for more information]
-- heap-console> foo
-- 42
-- ...
-- [Exiting heap-view]
evidence :: Applicative f => String -> a -> f ()
evidence :: String -> a -> f ()
evidence String
n a
v = String -> a -> f () -> f ()
forall a b. String -> a -> b -> b
withEvidence String
n a
v (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Version of 'evidence' providing more precise inspection using 'Data' -
-- prefer this one where possible.
--
-- >>> evidenceD "foo" 42
-- >>> inspection
-- [Entering heap-view - use `:help` for more information]
-- heap-console> foo
-- 42
-- ...
-- [Exiting heap-view]
evidenceD :: (Data a, Applicative f) => String -> a -> f ()
evidenceD :: String -> a -> f ()
evidenceD String
n a
v = String -> a -> f () -> f ()
forall a b. Data a => String -> a -> b -> b
withEvidenceD String
n a
v (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
withSomeEvidence :: String -> Either Box Value -> a -> a
withSomeEvidence :: String -> Either Box Value -> a -> a
withSomeEvidence String
n Either Box Value
v = () -> a -> a
seq (() -> a -> a) -> () -> a -> a
forall a b. (a -> b) -> a -> b
$ IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ String -> Either Box Value -> IO ()
addEvidence String
n Either Box Value
v

consoleWithEvidence :: IO Console
consoleWithEvidence :: IO Console
consoleWithEvidence = IORef (Map String (Either Box Value))
-> IO (Map String (Either Box Value))
forall a. IORef a -> IO a
readIORef IORef (Map String (Either Box Value))
unsafeCollectedEvidence IO (Map String (Either Box Value))
-> (Map String (Either Box Value) -> Console) -> IO Console
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map String (Either Box Value)
consoleBinds ->
  Console
defaultConsole{ Map String (Either Box Value)
consoleBinds :: Map String (Either Box Value)
consoleBinds :: Map String (Either Box Value)
consoleBinds }

addEvidence :: String -> Either Box Value -> IO ()
addEvidence :: String -> Either Box Value -> IO ()
addEvidence String
n Either Box Value
v =
  IORef (Map String (Either Box Value))
-> (Map String (Either Box Value)
    -> (Map String (Either Box Value), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map String (Either Box Value))
unsafeCollectedEvidence ((Map String (Either Box Value)
  -> (Map String (Either Box Value), ()))
 -> IO ())
-> (Map String (Either Box Value)
    -> (Map String (Either Box Value), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (,()) (Map String (Either Box Value)
 -> (Map String (Either Box Value), ()))
-> (Map String (Either Box Value) -> Map String (Either Box Value))
-> Map String (Either Box Value)
-> (Map String (Either Box Value), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Either Box Value
-> Map String (Either Box Value)
-> Map String (Either Box Value)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
n Either Box Value
v

unsafeCollectedEvidence :: IORef (Map String (Either Box Value))
unsafeCollectedEvidence :: IORef (Map String (Either Box Value))
unsafeCollectedEvidence = IO (IORef (Map String (Either Box Value)))
-> IORef (Map String (Either Box Value))
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map String (Either Box Value)))
 -> IORef (Map String (Either Box Value)))
-> IO (IORef (Map String (Either Box Value)))
-> IORef (Map String (Either Box Value))
forall a b. (a -> b) -> a -> b
$ Map String (Either Box Value)
-> IO (IORef (Map String (Either Box Value)))
forall a. a -> IO (IORef a)
newIORef Map String (Either Box Value)
forall k a. Map k a
M.empty
{-# noinline unsafeCollectedEvidence #-}

-------------------------------------------------------------------------------
newtype ConsoleM a = ConsoleM{ ConsoleM a -> StateT Console (InputT IO) a
unConsoleM :: StateT Console (InputT IO) a }
  deriving newtype
    ( Functor ConsoleM
a -> ConsoleM a
Functor ConsoleM
-> (forall a. a -> ConsoleM a)
-> (forall a b. ConsoleM (a -> b) -> ConsoleM a -> ConsoleM b)
-> (forall a b c.
    (a -> b -> c) -> ConsoleM a -> ConsoleM b -> ConsoleM c)
-> (forall a b. ConsoleM a -> ConsoleM b -> ConsoleM b)
-> (forall a b. ConsoleM a -> ConsoleM b -> ConsoleM a)
-> Applicative ConsoleM
ConsoleM a -> ConsoleM b -> ConsoleM b
ConsoleM a -> ConsoleM b -> ConsoleM a
ConsoleM (a -> b) -> ConsoleM a -> ConsoleM b
(a -> b -> c) -> ConsoleM a -> ConsoleM b -> ConsoleM c
forall a. a -> ConsoleM a
forall a b. ConsoleM a -> ConsoleM b -> ConsoleM a
forall a b. ConsoleM a -> ConsoleM b -> ConsoleM b
forall a b. ConsoleM (a -> b) -> ConsoleM a -> ConsoleM b
forall a b c.
(a -> b -> c) -> ConsoleM a -> ConsoleM b -> ConsoleM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ConsoleM a -> ConsoleM b -> ConsoleM a
$c<* :: forall a b. ConsoleM a -> ConsoleM b -> ConsoleM a
*> :: ConsoleM a -> ConsoleM b -> ConsoleM b
$c*> :: forall a b. ConsoleM a -> ConsoleM b -> ConsoleM b
liftA2 :: (a -> b -> c) -> ConsoleM a -> ConsoleM b -> ConsoleM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> ConsoleM a -> ConsoleM b -> ConsoleM c
<*> :: ConsoleM (a -> b) -> ConsoleM a -> ConsoleM b
$c<*> :: forall a b. ConsoleM (a -> b) -> ConsoleM a -> ConsoleM b
pure :: a -> ConsoleM a
$cpure :: forall a. a -> ConsoleM a
$cp1Applicative :: Functor ConsoleM
Applicative, a -> ConsoleM b -> ConsoleM a
(a -> b) -> ConsoleM a -> ConsoleM b
(forall a b. (a -> b) -> ConsoleM a -> ConsoleM b)
-> (forall a b. a -> ConsoleM b -> ConsoleM a) -> Functor ConsoleM
forall a b. a -> ConsoleM b -> ConsoleM a
forall a b. (a -> b) -> ConsoleM a -> ConsoleM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ConsoleM b -> ConsoleM a
$c<$ :: forall a b. a -> ConsoleM b -> ConsoleM a
fmap :: (a -> b) -> ConsoleM a -> ConsoleM b
$cfmap :: forall a b. (a -> b) -> ConsoleM a -> ConsoleM b
Functor, Applicative ConsoleM
a -> ConsoleM a
Applicative ConsoleM
-> (forall a b. ConsoleM a -> (a -> ConsoleM b) -> ConsoleM b)
-> (forall a b. ConsoleM a -> ConsoleM b -> ConsoleM b)
-> (forall a. a -> ConsoleM a)
-> Monad ConsoleM
ConsoleM a -> (a -> ConsoleM b) -> ConsoleM b
ConsoleM a -> ConsoleM b -> ConsoleM b
forall a. a -> ConsoleM a
forall a b. ConsoleM a -> ConsoleM b -> ConsoleM b
forall a b. ConsoleM a -> (a -> ConsoleM b) -> ConsoleM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ConsoleM a
$creturn :: forall a. a -> ConsoleM a
>> :: ConsoleM a -> ConsoleM b -> ConsoleM b
$c>> :: forall a b. ConsoleM a -> ConsoleM b -> ConsoleM b
>>= :: ConsoleM a -> (a -> ConsoleM b) -> ConsoleM b
$c>>= :: forall a b. ConsoleM a -> (a -> ConsoleM b) -> ConsoleM b
$cp1Monad :: Applicative ConsoleM
Monad, MonadThrow ConsoleM
MonadThrow ConsoleM
-> (forall e a.
    Exception e =>
    ConsoleM a -> (e -> ConsoleM a) -> ConsoleM a)
-> MonadCatch ConsoleM
ConsoleM a -> (e -> ConsoleM a) -> ConsoleM a
forall e a.
Exception e =>
ConsoleM a -> (e -> ConsoleM a) -> ConsoleM a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: ConsoleM a -> (e -> ConsoleM a) -> ConsoleM a
$ccatch :: forall e a.
Exception e =>
ConsoleM a -> (e -> ConsoleM a) -> ConsoleM a
$cp1MonadCatch :: MonadThrow ConsoleM
MonadCatch, Monad ConsoleM
Monad ConsoleM
-> (forall a. IO a -> ConsoleM a) -> MonadIO ConsoleM
IO a -> ConsoleM a
forall a. IO a -> ConsoleM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ConsoleM a
$cliftIO :: forall a. IO a -> ConsoleM a
$cp1MonadIO :: Monad ConsoleM
MonadIO, MonadCatch ConsoleM
MonadCatch ConsoleM
-> (forall b.
    ((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b)
-> (forall b.
    ((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b)
-> (forall a b c.
    ConsoleM a
    -> (a -> ExitCase b -> ConsoleM c)
    -> (a -> ConsoleM b)
    -> ConsoleM (b, c))
-> MonadMask ConsoleM
ConsoleM a
-> (a -> ExitCase b -> ConsoleM c)
-> (a -> ConsoleM b)
-> ConsoleM (b, c)
((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
forall b.
((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
forall a b c.
ConsoleM a
-> (a -> ExitCase b -> ConsoleM c)
-> (a -> ConsoleM b)
-> ConsoleM (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: ConsoleM a
-> (a -> ExitCase b -> ConsoleM c)
-> (a -> ConsoleM b)
-> ConsoleM (b, c)
$cgeneralBracket :: forall a b c.
ConsoleM a
-> (a -> ExitCase b -> ConsoleM c)
-> (a -> ConsoleM b)
-> ConsoleM (b, c)
uninterruptibleMask :: ((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
$cuninterruptibleMask :: forall b.
((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
mask :: ((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
$cmask :: forall b.
((forall a. ConsoleM a -> ConsoleM a) -> ConsoleM b) -> ConsoleM b
$cp1MonadMask :: MonadCatch ConsoleM
MonadMask
    , MonadState Console, Monad ConsoleM
e -> ConsoleM a
Monad ConsoleM
-> (forall e a. Exception e => e -> ConsoleM a)
-> MonadThrow ConsoleM
forall e a. Exception e => e -> ConsoleM a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> ConsoleM a
$cthrowM :: forall e a. Exception e => e -> ConsoleM a
$cp1MonadThrow :: Monad ConsoleM
MonadThrow
    )

data Console = Console{
    Console -> RepOptions
consoleRepOptions :: RepOptions
  , Console -> String
consolePrompt     :: String
  , Console -> Map String (Either Box Value)
consoleBinds      :: Map String (Either Box Value)
  } deriving stock Int -> Console -> ShowS
[Console] -> ShowS
Console -> String
(Int -> Console -> ShowS)
-> (Console -> String) -> ([Console] -> ShowS) -> Show Console
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Console] -> ShowS
$cshowList :: [Console] -> ShowS
show :: Console -> String
$cshow :: Console -> String
showsPrec :: Int -> Console -> ShowS
$cshowsPrec :: Int -> Console -> ShowS
Show

defaultConsole :: Console
defaultConsole :: Console
defaultConsole = RepOptions -> String -> Map String (Either Box Value) -> Console
Console (Natural -> Bool -> Bool -> RepOptions
RepOptions Natural
16 Bool
False Bool
False) String
"heap-console> " Map String (Either Box Value)
forall k a. Map k a
M.empty

data ConsoleExit = ConsoleExit
  deriving stock Int -> ConsoleExit -> ShowS
[ConsoleExit] -> ShowS
ConsoleExit -> String
(Int -> ConsoleExit -> ShowS)
-> (ConsoleExit -> String)
-> ([ConsoleExit] -> ShowS)
-> Show ConsoleExit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConsoleExit] -> ShowS
$cshowList :: [ConsoleExit] -> ShowS
show :: ConsoleExit -> String
$cshow :: ConsoleExit -> String
showsPrec :: Int -> ConsoleExit -> ShowS
$cshowsPrec :: Int -> ConsoleExit -> ShowS
Show
  deriving anyclass Show ConsoleExit
Typeable ConsoleExit
Typeable ConsoleExit
-> Show ConsoleExit
-> (ConsoleExit -> SomeException)
-> (SomeException -> Maybe ConsoleExit)
-> (ConsoleExit -> String)
-> Exception ConsoleExit
SomeException -> Maybe ConsoleExit
ConsoleExit -> String
ConsoleExit -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: ConsoleExit -> String
$cdisplayException :: ConsoleExit -> String
fromException :: SomeException -> Maybe ConsoleExit
$cfromException :: SomeException -> Maybe ConsoleExit
toException :: ConsoleExit -> SomeException
$ctoException :: ConsoleExit -> SomeException
$cp2Exception :: Show ConsoleExit
$cp1Exception :: Typeable ConsoleExit
Exception

runConsoleM :: Console -> ConsoleM a -> IO (Maybe a)
runConsoleM :: Console -> ConsoleM a -> IO (Maybe a)
runConsoleM Console
c = (ConsoleExit -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\ConsoleExit
ConsoleExit -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) (IO (Maybe a) -> IO (Maybe a))
-> (ConsoleM a -> IO (Maybe a)) -> ConsoleM a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
              (IO a -> IO (Maybe a))
-> (ConsoleM a -> IO a) -> ConsoleM a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings IO -> InputT IO a -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings (InputT IO a -> IO a)
-> (ConsoleM a -> InputT IO a) -> ConsoleM a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT Console (InputT IO) a -> Console -> InputT IO a)
-> Console -> StateT Console (InputT IO) a -> InputT IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Console (InputT IO) a -> Console -> InputT IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Console
c (StateT Console (InputT IO) a -> InputT IO a)
-> (ConsoleM a -> StateT Console (InputT IO) a)
-> ConsoleM a
-> InputT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleM a -> StateT Console (InputT IO) a
forall a. ConsoleM a -> StateT Console (InputT IO) a
unConsoleM

exitConsole :: ConsoleM a
exitConsole :: ConsoleM a
exitConsole = ConsoleExit -> ConsoleM a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConsoleExit
ConsoleExit

liftRepM :: RepM a -> ConsoleM (Either String a)
liftRepM :: RepM a -> ConsoleM (Either String a)
liftRepM RepM a
ma = StateT Console (InputT IO) (Either String a)
-> ConsoleM (Either String a)
forall a. StateT Console (InputT IO) a -> ConsoleM a
ConsoleM (StateT Console (InputT IO) (Either String a)
 -> ConsoleM (Either String a))
-> StateT Console (InputT IO) (Either String a)
-> ConsoleM (Either String a)
forall a b. (a -> b) -> a -> b
$ IO (Either String a)
-> StateT Console (InputT IO) (Either String a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a)
 -> StateT Console (InputT IO) (Either String a))
-> (RepOptions -> IO (Either String a))
-> RepOptions
-> StateT Console (InputT IO) (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepM a -> RepOptions -> IO (Either String a)
forall a. RepM a -> RepOptions -> IO (Either String a)
runRepM RepM a
ma (RepOptions -> StateT Console (InputT IO) (Either String a))
-> StateT Console (InputT IO) RepOptions
-> StateT Console (InputT IO) (Either String a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Console -> RepOptions) -> StateT Console (InputT IO) RepOptions
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Console -> RepOptions
consoleRepOptions

withRepM :: RepM a -> (a -> ConsoleM ()) -> ConsoleM ()
withRepM :: RepM a -> (a -> ConsoleM ()) -> ConsoleM ()
withRepM RepM a
ma a -> ConsoleM ()
f = RepM a -> ConsoleM (Either String a)
forall a. RepM a -> ConsoleM (Either String a)
liftRepM RepM a
ma ConsoleM (Either String a)
-> (Either String a -> ConsoleM ()) -> ConsoleM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ConsoleM ())
-> (a -> ConsoleM ()) -> Either String a -> ConsoleM ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ConsoleM ()
errorC a -> ConsoleM ()
f

putStrLnC :: String -> ConsoleM ()
putStrLnC :: String -> ConsoleM ()
putStrLnC = StateT Console (InputT IO) () -> ConsoleM ()
forall a. StateT Console (InputT IO) a -> ConsoleM a
ConsoleM (StateT Console (InputT IO) () -> ConsoleM ())
-> (String -> StateT Console (InputT IO) ())
-> String
-> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT IO () -> StateT Console (InputT IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO () -> StateT Console (InputT IO) ())
-> (String -> InputT IO ())
-> String
-> StateT Console (InputT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT IO ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn

getLnC :: ConsoleM String
getLnC :: ConsoleM String
getLnC = ConsoleM String
-> (String -> ConsoleM String) -> Maybe String -> ConsoleM String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConsoleM String
forall a. ConsoleM a
exitConsole String -> ConsoleM String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> ConsoleM String)
-> ConsoleM (Maybe String) -> ConsoleM String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT Console (InputT IO) (Maybe String)
-> ConsoleM (Maybe String)
forall a. StateT Console (InputT IO) a -> ConsoleM a
ConsoleM do
  InputT IO (Maybe String)
-> StateT Console (InputT IO) (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO (Maybe String)
 -> StateT Console (InputT IO) (Maybe String))
-> (String -> InputT IO (Maybe String))
-> String
-> StateT Console (InputT IO) (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT IO (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine (String -> StateT Console (InputT IO) (Maybe String))
-> StateT Console (InputT IO) String
-> StateT Console (InputT IO) (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Console -> String) -> StateT Console (InputT IO) String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Console -> String
consolePrompt

errorC :: String -> ConsoleM ()
errorC :: String -> ConsoleM ()
errorC = StateT Console (InputT IO) () -> ConsoleM ()
forall a. StateT Console (InputT IO) a -> ConsoleM a
ConsoleM (StateT Console (InputT IO) () -> ConsoleM ())
-> (String -> StateT Console (InputT IO) ())
-> String
-> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT IO () -> StateT Console (InputT IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO () -> StateT Console (InputT IO) ())
-> (String -> InputT IO ())
-> String
-> StateT Console (InputT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT IO ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn (String -> InputT IO ()) -> ShowS -> String -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++)

catchInterrupt :: ConsoleM () -> ConsoleM ()
catchInterrupt :: ConsoleM () -> ConsoleM ()
catchInterrupt (ConsoleM StateT Console (InputT IO) ()
ma) =
  ConsoleM () -> ConsoleM () -> ConsoleM ()
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
handleInterrupt (() -> ConsoleM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (ConsoleM () -> ConsoleM ()) -> ConsoleM () -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ StateT Console (InputT IO) () -> ConsoleM ()
forall a. StateT Console (InputT IO) a -> ConsoleM a
ConsoleM (StateT Console (InputT IO) () -> ConsoleM ())
-> StateT Console (InputT IO) () -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ (InputT IO ((), Console) -> InputT IO ((), Console))
-> StateT Console (InputT IO) () -> StateT Console (InputT IO) ()
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT InputT IO ((), Console) -> InputT IO ((), Console)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
withInterrupt StateT Console (InputT IO) ()
ma

heapConsole :: Console -> IO ()
heapConsole :: Console -> IO ()
heapConsole Console
c = do
  String -> IO ()
putStrLn String
"[Entering heap-view - use `:help` for more information]"
  Maybe Any
_ <- Console -> ConsoleM Any -> IO (Maybe Any)
forall a. Console -> ConsoleM a -> IO (Maybe a)
runConsoleM Console
c (ConsoleM Any -> IO (Maybe Any)) -> ConsoleM Any -> IO (Maybe Any)
forall a b. (a -> b) -> a -> b
$ ConsoleM () -> ConsoleM Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ConsoleM () -> ConsoleM Any) -> ConsoleM () -> ConsoleM Any
forall a b. (a -> b) -> a -> b
$ ConsoleM () -> ConsoleM ()
catchInterrupt (ConsoleM () -> ConsoleM ()) -> ConsoleM () -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$
    (String -> ConsoleM ())
-> ([String] -> ConsoleM ())
-> Either String [String]
-> ConsoleM ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ConsoleM ()
errorC [String] -> ConsoleM ()
commands (Either String [String] -> ConsoleM ())
-> (String -> Either String [String]) -> String -> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String [String]
parseCommand (String -> ConsoleM ()) -> ConsoleM String -> ConsoleM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConsoleM String
getLnC
  String -> IO ()
putStrLn String
"[Exiting heap-view]"

commands :: [String] -> ConsoleM ()
commands :: [String] -> ConsoleM ()
commands = \case
  [] -> () -> ConsoleM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  String
":help":[String]
_ -> String -> ConsoleM ()
putStrLnC
    -- TODO: move descriptions of options to 'Option'?
    String
"Usage:\n\
    \  :help                    - shows this text.\n\
    \  :exit | :quit | <ctrl-D> - returns back to program.\n\
    \  :show [OPTION]           - shows value of a selected option, or values of all\n\
    \                             options if not given any. Available options:\n\
    \    depth :: Natural\n\
    \      depth of printed representation\n\
    \    showTypes :: Bool\n\
    \      whether to show types in printed representation\n\
    \    prompt :: String\n\
    \      console prompt\n\
    \    strict :: Bool\n\
    \      whether inspection should always force values along the way\n\
    \\n\
    \  :set OPTION VALUE        - changes option to given value.\n\
    \  NAME = SELECTION         - binds result of SELECTION to NAME.\n\
    \  [!]SELECTION             - prints selection [strictly].\n\
    \  :info SELECTION          - prints info about selected value.\n\
    \  :binds                   - lists bindings in scope."

  String
":exit":[String]
_ -> ConsoleM ()
forall a. ConsoleM a
exitConsole
  String
":quit":[String]
_ -> ConsoleM ()
forall a. ConsoleM a
exitConsole

  String
":show":String
o:[String]
_ -> String -> (Option Console -> ConsoleM ()) -> ConsoleM ()
withOption String
o \Option Console
l -> String -> ConsoleM ()
putStrLnC (String -> ConsoleM ())
-> (Console -> String) -> Console -> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option Console -> Console -> String
forall a. Option a -> a -> String
view Option Console
l (Console -> ConsoleM ()) -> ConsoleM Console -> ConsoleM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConsoleM Console
forall s (m :: * -> *). MonadState s m => m s
get
  String
":show":[]  -> [(String, Option Console)]
-> ((String, Option Console) -> ConsoleM ()) -> ConsoleM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map String (Option Console) -> [(String, Option Console)]
forall k a. Map k a -> [(k, a)]
M.toList Map String (Option Console)
options) \(String
o, Option Console
l) ->
    String -> ConsoleM ()
putStrLnC (String -> ConsoleM ())
-> (Console -> String) -> Console -> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (String
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = ") ShowS -> (Console -> String) -> Console -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option Console -> Console -> String
forall a. Option a -> a -> String
view Option Console
l (Console -> ConsoleM ()) -> ConsoleM Console -> ConsoleM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConsoleM Console
forall s (m :: * -> *). MonadState s m => m s
get
  String
":show":[String]
_   -> String -> ConsoleM ()
errorC String
"expecting option name or no argument in `:show`"

  String
":set":String
o:String
v:[String]
_ -> String -> (Option Console -> ConsoleM ()) -> ConsoleM ()
withOption String
o \Option Console
l -> case Option Console -> String -> Maybe (Console -> Console)
forall a. Option a -> String -> Maybe (a -> a)
set Option Console
l String
v of
    Maybe (Console -> Console)
Nothing -> String -> ConsoleM ()
errorC (String -> ConsoleM ()) -> String -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ String
"invalid value for option `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
    Just Console -> Console
f  -> (Console -> Console) -> ConsoleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Console -> Console
f
  String
":set":[String]
_     -> String -> ConsoleM ()
errorC String
"expecting option name and value in `:set`"

  String
":info":String
s:[String]
_ -> String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withSelected String
s ((Either Box Value -> ConsoleM ()) -> ConsoleM ())
-> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$
    String -> ConsoleM ()
putStrLnC (String -> ConsoleM ())
-> (Closure -> String) -> Closure -> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> String
forall a. Show a => a -> String
show (Closure -> ConsoleM ())
-> (Either Box Value -> ConsoleM Closure)
-> Either Box Value
-> ConsoleM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO Closure -> ConsoleM Closure
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Closure -> ConsoleM Closure)
-> (Either Box Value -> IO Closure)
-> Either Box Value
-> ConsoleM Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Box -> IO Closure)
-> (Value -> IO Closure) -> Either Box Value -> IO Closure
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Box -> IO Closure
getBoxedClosureData (\(Value a
v) -> a -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
getClosureData a
v)
  String
":info":[String]
_   -> String -> ConsoleM ()
errorC String
"expecting selection in `:info`"

  String
":binds":[] -> (Console -> Map String (Either Box Value))
-> ConsoleM (Map String (Either Box Value))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Console -> Map String (Either Box Value)
consoleBinds ConsoleM (Map String (Either Box Value))
-> (Map String (Either Box Value) -> ConsoleM ()) -> ConsoleM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ConsoleM ()) -> [String] -> ConsoleM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> ConsoleM ()
putStrLnC ([String] -> ConsoleM ())
-> (Map String (Either Box Value) -> [String])
-> Map String (Either Box Value)
-> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (Either Box Value) -> [String]
forall k a. Map k a -> [k]
M.keys
  String
":binds":[String]
_  -> String -> ConsoleM ()
errorC String
"expecting no arguments in `:binds`"

  c :: String
c@(Char
':':String
_):[String]
_ -> String -> ConsoleM ()
errorC (String -> ConsoleM ()) -> String -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ String
"unknown command `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"

  String
n:String
"=":String
s:[String]
_
    | String -> Bool
isIdentifier String
n -> String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withSelected String
s \Either Box Value
v -> (Console -> Console) -> ConsoleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify \Console
c ->
      Console
c{ consoleBinds :: Map String (Either Box Value)
consoleBinds = String
-> Either Box Value
-> Map String (Either Box Value)
-> Map String (Either Box Value)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
n Either Box Value
v (Map String (Either Box Value) -> Map String (Either Box Value))
-> Map String (Either Box Value) -> Map String (Either Box Value)
forall a b. (a -> b) -> a -> b
$ Console -> Map String (Either Box Value)
consoleBinds Console
c }
    | Bool
otherwise -> String -> ConsoleM ()
errorC (String -> ConsoleM ()) -> String -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"` isn't valid binding name"

  String
s:[] -> String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withSelected String
s \Either Box Value
v -> RepM String -> (String -> ConsoleM ()) -> ConsoleM ()
forall a. RepM a -> (a -> ConsoleM ()) -> ConsoleM ()
withRepM (Either Box Value -> RepM String
prettyRep Either Box Value
v) String -> ConsoleM ()
putStrLnC

  [String]
_ -> String -> ConsoleM ()
errorC String
"couldn't parse input"

parseCommand :: String -> Either String [String]
parseCommand :: String -> Either String [String]
parseCommand = String -> Either String [String]
goSpaced where
  goSpaced :: String -> Either String [String]
goSpaced = \case
    [] -> [String] -> Either String [String]
forall a b. b -> Either a b
Right []
    String
cs -> do
      (String
x, String
cs') <- Bool -> String -> Either String (String, String)
goLexeme Bool
False ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
cs)
      (String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> Either String [String] -> Either String [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String [String]
goSpaced String
cs'
  goLexeme :: Bool -> String -> Either String (String, String)
goLexeme Bool
q = \case
    String
"" | Bool -> Bool
not Bool
q     -> (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right ([], [])
       | Bool
otherwise -> String -> Either String (String, String)
forall a b. a -> Either a b
Left String
"unexpected end of line, expected quote '\"'"
    Char
'\\':Char
'"':String
cs    -> ShowS -> (String, String) -> (String, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:) ((String, String) -> (String, String))
-> Either String (String, String) -> Either String (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Either String (String, String)
goLexeme Bool
q String
cs
    Char
'"':String
cs         -> Bool -> String -> Either String (String, String)
goLexeme (Bool -> Bool
not Bool
q) String
cs
    Char
' ':String
cs | Bool -> Bool
not Bool
q -> (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right ([], String
cs)
    Char
c:String
cs           -> ShowS -> (String, String) -> (String, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:) ((String, String) -> (String, String))
-> Either String (String, String) -> Either String (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> String -> Either String (String, String)
goLexeme Bool
q String
cs

parseSelection :: String -> Either String (Bool, String, [String])
parseSelection :: String -> Either String (Bool, String, [String])
parseSelection = \case
  Char
'!':String
cs -> (String -> [String] -> (Bool, String, [String]))
-> (String, [String]) -> (Bool, String, [String])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool
True,,)  ((String, [String]) -> (Bool, String, [String]))
-> Either String (String, [String])
-> Either String (Bool, String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String (String, [String])
go String
cs
  String
cs     -> (String -> [String] -> (Bool, String, [String]))
-> (String, [String]) -> (Bool, String, [String])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool
False,,) ((String, [String]) -> (Bool, String, [String]))
-> Either String (String, [String])
-> Either String (Bool, String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String (String, [String])
go String
cs
 where
  go :: String -> Either String (String, [String])
go = (Char -> Char -> Bool) -> String -> [String]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Char
_ Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> [String])
-> ([String] -> Either String (String, [String]))
-> String
-> Either String (String, [String])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    []   -> String -> Either String (String, [String])
forall a b. a -> Either a b
Left String
"missing selection"
    String
n:[String]
is -> (String, [String]) -> Either String (String, [String])
forall a b. b -> Either a b
Right (String
n, ShowS
forall a. [a] -> [a]
tail ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
is)

isIdentifier :: String -> Bool
isIdentifier :: String -> Bool
isIdentifier = \case
  [] -> Bool
False
  Char
c:String
cs -> (Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Bool
isAlphaNum (Char -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')) String
cs

withBind :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withBind :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withBind String
n Either Box Value -> ConsoleM ()
f = ConsoleM ()
-> (Either Box Value -> ConsoleM ())
-> Maybe (Either Box Value)
-> ConsoleM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ConsoleM ()
errorC (String -> ConsoleM ()) -> String -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ String
"binding `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"` not in scope") Either Box Value -> ConsoleM ()
f (Maybe (Either Box Value) -> ConsoleM ())
-> (Map String (Either Box Value) -> Maybe (Either Box Value))
-> Map String (Either Box Value)
-> ConsoleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> Map String (Either Box Value) -> Maybe (Either Box Value)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
n (Map String (Either Box Value) -> ConsoleM ())
-> ConsoleM (Map String (Either Box Value)) -> ConsoleM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Console -> Map String (Either Box Value))
-> ConsoleM (Map String (Either Box Value))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Console -> Map String (Either Box Value)
consoleBinds

withSelected :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withSelected :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withSelected String
s Either Box Value -> ConsoleM ()
f = String -> Either String (Bool, String, [String])
parseSelection String
s Either String (Bool, String, [String])
-> (Either String (Bool, String, [String]) -> ConsoleM ())
-> ConsoleM ()
forall a b. a -> (a -> b) -> b
& (String -> ConsoleM ())
-> ((Bool, String, [String]) -> ConsoleM ())
-> Either String (Bool, String, [String])
-> ConsoleM ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ConsoleM ()
errorC \(Bool
strict, String
n, [String]
is) ->
  String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withBind String
n \Either Box Value
v -> RepM (Either Box Value)
-> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
forall a. RepM a -> (a -> ConsoleM ()) -> ConsoleM ()
withRepM (Either Box Value -> Bool -> [String] -> RepM (Either Box Value)
index Either Box Value
v Bool
strict [String]
is) Either Box Value -> ConsoleM ()
f

withOption :: String -> (Option Console -> ConsoleM ()) -> ConsoleM ()
withOption :: String -> (Option Console -> ConsoleM ()) -> ConsoleM ()
withOption String
o Option Console -> ConsoleM ()
f =
  ConsoleM ()
-> (Option Console -> ConsoleM ())
-> Maybe (Option Console)
-> ConsoleM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ConsoleM ()
errorC (String -> ConsoleM ()) -> String -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ String
"there's no option `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`") Option Console -> ConsoleM ()
f (Maybe (Option Console) -> ConsoleM ())
-> Maybe (Option Console) -> ConsoleM ()
forall a b. (a -> b) -> a -> b
$ String -> Map String (Option Console) -> Maybe (Option Console)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
o Map String (Option Console)
options

options :: Map String (Option Console)
options :: Map String (Option Console)
options = [(String, Option Console)] -> Map String (Option Console)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ ( String
"depth"
    , (Console -> Natural)
-> (Natural -> Console -> Console) -> Option Console
forall a x.
(Show a, Read a) =>
(x -> a) -> (a -> x -> x) -> Option x
option (RepOptions -> Natural
repDepth (RepOptions -> Natural)
-> (Console -> RepOptions) -> Console -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Console -> RepOptions
consoleRepOptions) \Natural
repDepth Console
c ->
        Console
c{ consoleRepOptions :: RepOptions
consoleRepOptions = (Console -> RepOptions
consoleRepOptions Console
c){ Natural
repDepth :: Natural
repDepth :: Natural
repDepth } }
    )
  , ( String
"showTypes"
    , (Console -> Bool) -> (Bool -> Console -> Console) -> Option Console
forall a x.
(Show a, Read a) =>
(x -> a) -> (a -> x -> x) -> Option x
option (RepOptions -> Bool
repTypes (RepOptions -> Bool) -> (Console -> RepOptions) -> Console -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Console -> RepOptions
consoleRepOptions) \Bool
repTypes Console
c ->
        Console
c{ consoleRepOptions :: RepOptions
consoleRepOptions = (Console -> RepOptions
consoleRepOptions Console
c){ Bool
repTypes :: Bool
repTypes :: Bool
repTypes } }
    )
  , ( String
"prompt"
    , (Console -> String)
-> (String -> Maybe (Console -> Console)) -> Option Console
forall a. (a -> String) -> (String -> Maybe (a -> a)) -> Option a
Option (ShowS
forall a. Show a => a -> String
show ShowS -> (Console -> String) -> Console -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Console -> String
consolePrompt) \String
consolePrompt ->
        (Console -> Console) -> Maybe (Console -> Console)
forall a. a -> Maybe a
Just \Console
c -> Console
c{ String
consolePrompt :: String
consolePrompt :: String
consolePrompt }
    )
  , ( String
"strict"
    , (Console -> Bool) -> (Bool -> Console -> Console) -> Option Console
forall a x.
(Show a, Read a) =>
(x -> a) -> (a -> x -> x) -> Option x
option (RepOptions -> Bool
repStrict (RepOptions -> Bool) -> (Console -> RepOptions) -> Console -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Console -> RepOptions
consoleRepOptions) \Bool
repStrict Console
c ->
        Console
c{ consoleRepOptions :: RepOptions
consoleRepOptions = (Console -> RepOptions
consoleRepOptions Console
c){ Bool
repStrict :: Bool
repStrict :: Bool
repStrict } }
    )
  ]

-------------------------------------------------------------------------------
data Option a = Option{ Option a -> a -> String
view :: a -> String, Option a -> String -> Maybe (a -> a)
set :: String -> Maybe (a -> a) }

option :: (Show a, Read a) => (x -> a) -> (a -> x -> x) -> Option x
option :: (x -> a) -> (a -> x -> x) -> Option x
option x -> a
f a -> x -> x
t = (x -> String) -> (String -> Maybe (x -> x)) -> Option x
forall a. (a -> String) -> (String -> Maybe (a -> a)) -> Option a
Option (a -> String
forall a. Show a => a -> String
show (a -> String) -> (x -> a) -> x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> a
f) ((String -> Maybe (x -> x)) -> Option x)
-> (String -> Maybe (x -> x)) -> Option x
forall a b. (a -> b) -> a -> b
$ (a -> x -> x) -> Maybe a -> Maybe (x -> x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> x -> x
t (Maybe a -> Maybe (x -> x))
-> (String -> Maybe a) -> String -> Maybe (x -> x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe