{-# 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
  = CommandErrExpectedNoInput
  -- ^ An option 'Command' got input when it expected None
  | CommandErrUnknownCommand !Text
  -- ^ An option 'Command' was not found by name.
  deriving stock (CommandErr -> CommandErr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommandErr -> CommandErr -> Bool
$c/= :: CommandErr -> CommandErr -> Bool
== :: CommandErr -> CommandErr -> Bool
$c== :: CommandErr -> CommandErr -> Bool
Eq, Int -> CommandErr -> ShowS
[CommandErr] -> ShowS
CommandErr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommandErr] -> ShowS
$cshowList :: [CommandErr] -> ShowS
show :: CommandErr -> String
$cshow :: CommandErr -> String
showsPrec :: Int -> CommandErr -> ShowS
$cshowsPrec :: Int -> 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 = forall k a. Map k a
Map.empty

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

assertEmpty :: MonadThrow m => Text -> m ()
assertEmpty :: forall (m :: * -> *). MonadThrow m => Text -> m ()
assertEmpty Text
input = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
input) (forall (m :: * -> *) e a. (MonadThrow m, 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 = forall (m :: * -> *). MonadThrow m => Text -> m ()
assertEmpty Text
input 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 = forall (m :: * -> *). MonadThrow m => m ReplDirective -> Command m
bareCommand (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 = forall (m :: * -> *). MonadThrow m => m ReplDirective -> Command m
bareCommand forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn Text
"Available commands:")
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList OptionCommands m
opts) forall a b. (a -> b) -> a -> b
$ \(Text
name, (Text
desc, Command m
_)) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn (Text
":" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\t" forall a. Semigroup a => a -> a -> a
<> Text
desc))
  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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"quit", (Text
"quit", forall (m :: * -> *). MonadThrow m => Command m
quitCommand))
    , (Text
"help", (Text
"describe all commands", 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 (forall a. Eq a => a -> a -> Bool
==Char
' ') Text
rest
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name OptionCommands m
opts of
        Maybe (Text, Command m)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, 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 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 = forall (m :: * -> *) e a.
(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 = forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchUserErr (Command m
action Text
input) forall a b. (a -> b) -> a -> b
$ \SomeException
err -> do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStr Text
"Caught error: ")
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Show a => a -> IO ()
print SomeException
err)
  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 = forall a. (a -> a) -> a
fix (\OptionCommands m
c -> forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
OptionCommands m -> OptionCommands m
defaultOptions OptionCommands m
c forall a. Semigroup a => a -> a -> a
<> OptionCommands m
opts)
      action :: Command m
action = forall (m :: * -> *).
MonadThrow m =>
OptionCommands m -> Command m -> Command m
outerCommand OptionCommands m
allOpts Command m
exec
      handledAction :: Command m
handledAction = forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
Command m -> Command m
handleUserErr Command m
action
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
TIO.putStrLn Text
greeting)
  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.")
  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
_) = forall (m :: * -> *).
MonadThrow m =>
OptionCommands m -> Command m -> Command m
outerCommand OptionCommands m
opts Command m
exec