{-# LANGUAGE OverloadedStrings #-}

-- | Building blocks for a GHCI-like REPL with colon-commands.
module Climb
  ( Command
  , CommandErr (..)
  , Completion
  , OptionCommands
  , ReplDef (..)
  , ReplDirective (..)
  , bareCommand
  , noOptionCommands
  , noCompletion
  , runReplDef
  , stepReplDef
  )
where

import Control.Exception (Exception (..), SomeAsyncException (..), SomeException)
import Control.Monad (unless)
import Control.Monad.Catch (MonadCatch, MonadThrow (..), catchIf)
import Control.Monad.Fix (fix)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.Foldable (for_)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as TIO
import Linenoise.Repl (ReplDirective (..), replM)

-- | A 'Command' takes some input, performs some effect, and returns a directive (continue or quit).
type Command m = Text -> m ReplDirective

-- | List of 'Command's by name with help text.
type OptionCommands m = Map Text (Text, Command m)

-- | A 'Completion' takes some input and returns potential matches.
type Completion m = Text -> m [Text]

-- | Sometimes things go wrong...
data CommandErr
  = -- | An option 'Command' got input when it expected None
    CommandErrExpectedNoInput
  | -- | An option 'Command' was not found by name.
    CommandErrUnknownCommand !Text
  deriving stock (CommandErr -> CommandErr -> Bool
(CommandErr -> CommandErr -> Bool)
-> (CommandErr -> CommandErr -> Bool) -> Eq CommandErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommandErr -> CommandErr -> Bool
== :: CommandErr -> CommandErr -> Bool
$c/= :: CommandErr -> CommandErr -> Bool
/= :: CommandErr -> CommandErr -> Bool
Eq, Int -> CommandErr -> ShowS
[CommandErr] -> ShowS
CommandErr -> String
(Int -> CommandErr -> ShowS)
-> (CommandErr -> String)
-> ([CommandErr] -> ShowS)
-> Show CommandErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandErr -> ShowS
showsPrec :: Int -> CommandErr -> ShowS
$cshow :: CommandErr -> String
show :: CommandErr -> String
$cshowList :: [CommandErr] -> ShowS
showList :: [CommandErr] -> ShowS
Show)

instance Exception CommandErr

-- | Defines a REPL with commands, options, and completion.
data ReplDef m = ReplDef
  { forall (m :: * -> *). ReplDef m -> ReplDirective
rdOnInterrupt :: !ReplDirective
  , forall (m :: * -> *). ReplDef m -> Text
rdGreeting :: !Text
  , forall (m :: * -> *). ReplDef m -> Text
rdPrompt :: !Text
  , forall (m :: * -> *). ReplDef m -> OptionCommands m
rdOptionCommands :: !(OptionCommands m)
  , forall (m :: * -> *). ReplDef m -> Command m
rdExecCommand :: !(Command m)
  , forall (m :: * -> *). ReplDef m -> Completion m
rdCompletion :: !(Completion m)
  }

noOptionCommands :: OptionCommands m
noOptionCommands :: forall (m :: * -> *). OptionCommands m
noOptionCommands = Map Text (Text, Command m)
forall k a. Map k a
Map.empty

noCompletion :: Applicative m => Completion m
noCompletion :: forall (m :: * -> *). Applicative m => Completion m
noCompletion = m [Text] -> Text -> m [Text]
forall a b. a -> b -> a
const ([Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])

assertEmpty :: MonadThrow m => Text -> m ()
assertEmpty :: forall (m :: * -> *). MonadThrow m => Text -> m ()
assertEmpty Text
input = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
input) (CommandErr -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM CommandErr
CommandErrExpectedNoInput)

-- | Helps you define commands that expect no input.
bareCommand :: MonadThrow m => m ReplDirective -> Command m
bareCommand :: forall (m :: * -> *). MonadThrow m => m ReplDirective -> Command m
bareCommand m ReplDirective
act Text
input = Text -> m ()
forall (m :: * -> *). MonadThrow m => Text -> m ()
assertEmpty Text
input m () -> m ReplDirective -> m ReplDirective
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ReplDirective
act

quitCommand :: MonadThrow m => Command m
quitCommand :: forall (m :: * -> *). MonadThrow m => Command m
quitCommand = m ReplDirective -> Command m
forall (m :: * -> *). MonadThrow m => m ReplDirective -> Command m
bareCommand (ReplDirective -> m ReplDirective
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReplDirective
ReplQuit)

helpCommand :: (MonadThrow m, MonadIO m) => OptionCommands m -> Command m
helpCommand :: forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
OptionCommands m -> Command m
helpCommand OptionCommands m
opts = m ReplDirective -> Command m
forall (m :: * -> *). MonadThrow m => m ReplDirective -> Command m
bareCommand (m ReplDirective -> Command m) -> m ReplDirective -> Command m
forall a b. (a -> b) -> a -> b
$ do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn Text
"Available commands:")
  [(Text, (Text, Command m))]
-> ((Text, (Text, Command m)) -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (OptionCommands m -> [(Text, (Text, Command m))]
forall k a. Map k a -> [(k, a)]
Map.toList OptionCommands m
opts) (((Text, (Text, Command m)) -> m ()) -> m ())
-> ((Text, (Text, Command m)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Text
name, (Text
desc, Command m
_)) -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn (Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc))
  ReplDirective -> m ReplDirective
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReplDirective
ReplContinue

defaultOptions :: (MonadThrow m, MonadIO m) => OptionCommands m -> OptionCommands m
defaultOptions :: forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
OptionCommands m -> OptionCommands m
defaultOptions OptionCommands m
opts =
  [(Text, (Text, Command m))] -> OptionCommands m
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"quit", (Text
"quit", Command m
forall (m :: * -> *). MonadThrow m => Command m
quitCommand))
    , (Text
"help", (Text
"describe all commands", OptionCommands m -> Command m
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
OptionCommands m -> Command m
helpCommand OptionCommands m
opts))
    ]

outerCommand :: MonadThrow m => OptionCommands m -> Command m -> Command m
outerCommand :: forall (m :: * -> *).
MonadThrow m =>
OptionCommands m -> Command m -> Command m
outerCommand OptionCommands m
opts Command m
exec Text
input =
  case Text -> Maybe (Char, Text)
Text.uncons Text
input of
    Just (Char
':', Text
rest) -> do
      let (Text
name, Text
subInput) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
rest
      case Text -> OptionCommands m -> Maybe (Text, Command m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name OptionCommands m
opts of
        Maybe (Text, Command m)
Nothing -> CommandErr -> m ReplDirective
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Text -> CommandErr
CommandErrUnknownCommand Text
name)
        Just (Text
_, Command m
command) -> Command m
command (Int -> Text -> Text
Text.drop Int
1 Text
subInput)
    Maybe (Char, Text)
_ -> Command m
exec Text
input

isUserErr :: SomeException -> Bool
isUserErr :: SomeException -> Bool
isUserErr SomeException
x =
  case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x of
    Just (SomeAsyncException e
_) -> Bool
False
    Maybe SomeAsyncException
_ -> Bool
True

catchUserErr :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchUserErr :: forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchUserErr = (SomeException -> Bool) -> m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Bool) -> m a -> (e -> m a) -> m a
catchIf SomeException -> Bool
isUserErr

handleUserErr :: (MonadCatch m, MonadIO m) => Command m -> Command m
handleUserErr :: forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
Command m -> Command m
handleUserErr Command m
action Text
input = m ReplDirective
-> (SomeException -> m ReplDirective) -> m ReplDirective
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchUserErr (Command m
action Text
input) ((SomeException -> m ReplDirective) -> m ReplDirective)
-> (SomeException -> m ReplDirective) -> m ReplDirective
forall a b. (a -> b) -> a -> b
$ \SomeException
err -> do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStr Text
"Caught error: ")
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
err)
  ReplDirective -> m ReplDirective
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReplDirective
ReplContinue

-- | Runs a REPL as defined.
runReplDef :: (MonadCatch m, MonadUnliftIO m) => ReplDef m -> m ()
runReplDef :: forall (m :: * -> *).
(MonadCatch m, MonadUnliftIO m) =>
ReplDef m -> m ()
runReplDef (ReplDef ReplDirective
onInterrupt Text
greeting Text
prompt OptionCommands m
opts Command m
exec Completion m
comp) = do
  let allOpts :: OptionCommands m
allOpts = (OptionCommands m -> OptionCommands m) -> OptionCommands m
forall a. (a -> a) -> a
fix (\OptionCommands m
c -> OptionCommands m -> OptionCommands m
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
OptionCommands m -> OptionCommands m
defaultOptions OptionCommands m
c OptionCommands m -> OptionCommands m -> OptionCommands m
forall a. Semigroup a => a -> a -> a
<> OptionCommands m
opts)
      action :: Command m
action = OptionCommands m -> Command m -> Command m
forall (m :: * -> *).
MonadThrow m =>
OptionCommands m -> Command m -> Command m
outerCommand OptionCommands m
allOpts Command m
exec
      handledAction :: Command m
handledAction = Command m -> Command m
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
Command m -> Command m
handleUserErr Command m
action
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn Text
greeting)
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn Text
"Enter `:quit` to exit or `:help` to see all commands.")
  ReplDirective -> Text -> Command m -> Completion m -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
ReplDirective
-> Text -> (Text -> m ReplDirective) -> (Text -> m [Text]) -> m ()
replM ReplDirective
onInterrupt Text
prompt Command m
handledAction Completion m
comp

-- | Processes a single line of input. Useful for testing.
-- (Note that this does not handle default option commands.)
stepReplDef :: MonadThrow m => ReplDef m -> Text -> m ReplDirective
stepReplDef :: forall (m :: * -> *).
MonadThrow m =>
ReplDef m -> Text -> m ReplDirective
stepReplDef (ReplDef ReplDirective
_ Text
_ Text
_ OptionCommands m
opts Command m
exec Completion m
_) = OptionCommands m -> Command m -> Command m
forall (m :: * -> *).
MonadThrow m =>
OptionCommands m -> Command m -> Command m
outerCommand OptionCommands m
opts Command m
exec