Console.hs

{-# 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 = join 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 = join 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 = inspectingSome . Left . 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 = inspectingSome . Right . Value

inspectingSome :: Either Box Value -> b -> b
inspectingSome v = seq $ unsafePerformIO do
  c <- consoleWithEvidence
  heapConsole c{ consoleBinds = M.insert "it" v $ consoleBinds 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 = inspecting 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 = inspectingD 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 = withFrozenCallStack $ inspecting a $
  error "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 = withFrozenCallStack $ inspectingD a $
  error "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 = withInspection $ 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 =
  -- NOTE: do not eta reduce - GHC seems to memoize it as CAF in that case.
  unsafePerformIO (heapConsole =<< consoleWithEvidence) `seq` 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 = withFrozenCallStack $ withInspection $
  error "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 n = withSomeEvidence n . Left . 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 n = withSomeEvidence n . Right . 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 n v = withEvidence n v $ 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 n v = withEvidenceD n v $ pure ()

-------------------------------------------------------------------------------
withSomeEvidence :: String -> Either Box Value -> a -> a
withSomeEvidence n v = seq $ unsafePerformIO $ addEvidence n v

consoleWithEvidence :: IO Console
consoleWithEvidence = readIORef unsafeCollectedEvidence <&> \consoleBinds ->
  defaultConsole{ consoleBinds }

addEvidence :: String -> Either Box Value -> IO ()
addEvidence n v =
  atomicModifyIORef' unsafeCollectedEvidence $ (,()) . M.insert n v

unsafeCollectedEvidence :: IORef (Map String (Either Box Value))
unsafeCollectedEvidence = unsafePerformIO $ newIORef M.empty
{-# noinline unsafeCollectedEvidence #-}

-------------------------------------------------------------------------------
newtype ConsoleM a = ConsoleM{ unConsoleM :: StateT Console (InputT IO) a }
  deriving newtype
    ( Applicative, Functor, Monad, MonadCatch, MonadIO, MonadMask
    , MonadState Console, MonadThrow
    )

data Console = Console{
    consoleRepOptions :: RepOptions
  , consolePrompt     :: String
  , consoleBinds      :: Map String (Either Box Value)
  } deriving stock Show

defaultConsole :: Console
defaultConsole = Console (RepOptions 16 False False) "heap-console> " M.empty

data ConsoleExit = ConsoleExit
  deriving stock Show
  deriving anyclass Exception

runConsoleM :: Console -> ConsoleM a -> IO (Maybe a)
runConsoleM c = handle (\ConsoleExit -> pure Nothing) . fmap Just
              . runInputT defaultSettings . flip evalStateT c . unConsoleM

exitConsole :: ConsoleM a
exitConsole = throwM ConsoleExit

liftRepM :: RepM a -> ConsoleM (Either String a)
liftRepM ma = ConsoleM $ liftIO . runRepM ma =<< gets consoleRepOptions

withRepM :: RepM a -> (a -> ConsoleM ()) -> ConsoleM ()
withRepM ma f = liftRepM ma >>= either errorC f

putStrLnC :: String -> ConsoleM ()
putStrLnC = ConsoleM . lift . outputStrLn

getLnC :: ConsoleM String
getLnC = maybe exitConsole pure =<< ConsoleM do
  lift . getInputLine =<< gets consolePrompt

errorC :: String -> ConsoleM ()
errorC = ConsoleM . lift . outputStrLn . ("error: " ++)

catchInterrupt :: ConsoleM () -> ConsoleM ()
catchInterrupt (ConsoleM ma) =
  handleInterrupt (pure ()) $ ConsoleM $ mapStateT withInterrupt ma

heapConsole :: Console -> IO ()
heapConsole c = do
  putStrLn "[Entering heap-view - use `:help` for more information]"
  _ <- runConsoleM c $ forever $ catchInterrupt $
    either errorC commands . parseCommand =<< getLnC
  putStrLn "[Exiting heap-view]"

commands :: [String] -> ConsoleM ()
commands = \case
  [] -> pure ()

  ":help":_ -> putStrLnC
    -- TODO: move descriptions of options to 'Option'?
    "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."

  ":exit":_ -> exitConsole
  ":quit":_ -> exitConsole

  ":show":o:_ -> withOption o \l -> putStrLnC . view l =<< get
  ":show":[]  -> for_ (M.toList options) \(o, l) ->
    putStrLnC . (++) (o ++ " = ") . view l =<< get
  ":show":_   -> errorC "expecting option name or no argument in `:show`"

  ":set":o:v:_ -> withOption o \l -> case set l v of
    Nothing -> errorC $ "invalid value for option `" ++ o ++ "`"
    Just f  -> modify f
  ":set":_     -> errorC "expecting option name and value in `:set`"

  ":info":s:_ -> withSelected s $
    putStrLnC . show <=< liftIO .
      either getBoxedClosureData (\(Value v) -> getClosureData v)
  ":info":_   -> errorC "expecting selection in `:info`"

  ":binds":[] -> gets consoleBinds >>= traverse_ putStrLnC . M.keys
  ":binds":_  -> errorC "expecting no arguments in `:binds`"

  c@(':':_):_ -> errorC $ "unknown command `" ++ c ++ "`"

  n:"=":s:_
    | isIdentifier n -> withSelected s \v -> modify \c ->
      c{ consoleBinds = M.insert n v $ consoleBinds c }
    | otherwise -> errorC $ "`" ++ n ++ "` isn't valid binding name"

  s:[] -> withSelected s \v -> withRepM (prettyRep v) putStrLnC

  _ -> errorC "couldn't parse input"

parseCommand :: String -> Either String [String]
parseCommand = goSpaced where
  goSpaced = \case
    [] -> Right []
    cs -> do
      (x, cs') <- goLexeme False (dropWhile isSpace cs)
      (x :) <$> goSpaced cs'
  goLexeme q = \case
    "" | not q     -> Right ([], [])
       | otherwise -> Left "unexpected end of line, expected quote '\"'"
    '\\':'"':cs    -> first ('"':) <$> goLexeme q cs
    '"':cs         -> goLexeme (not q) cs
    ' ':cs | not q -> Right ([], cs)
    c:cs           -> first (c:) <$> goLexeme q cs

parseSelection :: String -> Either String (Bool, String, [String])
parseSelection = \case
  '!':cs -> uncurry (True,,)  <$> go cs
  cs     -> uncurry (False,,) <$> go cs
 where
  go = groupBy (\_ c -> c /= '.') >>> \case
    []   -> Left "missing selection"
    n:is -> Right (n, tail <$> is)

isIdentifier :: String -> Bool
isIdentifier = \case
  [] -> False
  c:cs -> (isAlpha c || c == '_') && all ((||) <$> isAlphaNum <*> (== '_')) cs

withBind :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withBind n f = maybe (errorC $ "binding `" ++ n ++ "` not in scope") f .
  M.lookup n =<< gets consoleBinds

withSelected :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()
withSelected s f = parseSelection s & either errorC \(strict, n, is) ->
  withBind n \v -> withRepM (index v strict is) f

withOption :: String -> (Option Console -> ConsoleM ()) -> ConsoleM ()
withOption o f =
  maybe (errorC $ "there's no option `" ++ o ++ "`") f $ M.lookup o options

options :: Map String (Option Console)
options = M.fromList
  [ ( "depth"
    , option (repDepth . consoleRepOptions) \repDepth c ->
        c{ consoleRepOptions = (consoleRepOptions c){ repDepth } }
    )
  , ( "showTypes"
    , option (repTypes . consoleRepOptions) \repTypes c ->
        c{ consoleRepOptions = (consoleRepOptions c){ repTypes } }
    )
  , ( "prompt"
    , Option (show . consolePrompt) \consolePrompt ->
        Just \c -> c{ consolePrompt }
    )
  , ( "strict"
    , option (repStrict . consoleRepOptions) \repStrict c ->
        c{ consoleRepOptions = (consoleRepOptions c){ repStrict } }
    )
  ]

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

option :: (Show a, Read a) => (x -> a) -> (a -> x -> x) -> Option x
option f t = Option (show . f) $ fmap t . readMaybe