{-# LANGUAGE OverloadedStrings #-}
module Climb
( Command
, CommandExc (..)
, Completion
, OptionCommands
, ReplDef (..)
, ReplDirective (..)
, bareCommand
, noOptionCommands
, noCompletion
, runReplDef
) where
import Control.Exception (Exception)
import Control.Monad (unless)
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.Fix (fix)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.Foldable (for_)
import Data.Typeable (Typeable)
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)
type Command m = Text -> m ReplDirective
type OptionCommands m = Map Text (Text, Command m)
type Completion m = Text -> m [Text]
data CommandExc
= ExpectedNoInputError
| MissingCommandError !Text
deriving (Eq, Show, Typeable)
instance Exception CommandExc
data ReplDef m =
ReplDef
{ _rdOnInterrupt :: !ReplDirective
, _rdGreeting :: !Text
, _rdPrompt :: !Text
, _rdOptionCommands :: !(OptionCommands m)
, _rdExecCommand :: !(Command m)
, _rdCompletion :: !(Completion m)
}
noOptionCommands :: OptionCommands m
noOptionCommands = Map.empty
noCompletion :: Applicative m => Completion m
noCompletion = const (pure [])
assertEmpty :: MonadThrow m => Text -> m ()
assertEmpty input = unless (Text.null input) (throwM ExpectedNoInputError)
bareCommand :: MonadThrow m => m ReplDirective -> Command m
bareCommand act input = assertEmpty input >> act
quitCommand :: MonadThrow m => Command m
quitCommand = bareCommand (pure ReplQuit)
helpCommand :: (MonadThrow m, MonadIO m) => OptionCommands m -> Command m
helpCommand opts = bareCommand $ do
liftIO (TIO.putStrLn "Available commands:")
for_ (Map.toList opts) $ \(name, (desc, _)) -> liftIO (TIO.putStrLn (":" <> name <> "\t" <> desc))
pure ReplContinue
defaultOptions :: (MonadThrow m, MonadIO m) => OptionCommands m -> OptionCommands m
defaultOptions opts = Map.fromList
[ ("quit", ("quit", quitCommand))
, ("help", ("describe all commands", helpCommand opts))
]
outerCommand :: MonadThrow m => OptionCommands m -> Command m -> Command m
outerCommand opts exec = \input ->
case Text.uncons input of
Just (':', rest) -> do
let (name, subInput) = Text.break (==' ') rest
case Map.lookup name opts of
Nothing -> throwM (MissingCommandError name)
Just (_, command) -> command (Text.drop 1 subInput)
_ -> exec input
runReplDef :: (MonadThrow m, MonadUnliftIO m) => ReplDef m -> m ()
runReplDef (ReplDef onInterrupt greeting prompt opts exec comp) = do
let allOpts = fix (\c -> defaultOptions c <> opts)
action = outerCommand allOpts exec
liftIO (TIO.putStrLn greeting)
liftIO (TIO.putStrLn "Enter `:quit` to exit or `:help` to see all commands.")
replM onInterrupt prompt action comp