structured-cli-2.0.0.0: src/System/Console/StructuredCLI.hs
{-# LANGUAGE ImplicitParams,
FlexibleContexts,
FlexibleInstances,
RecordWildCards,
TupleSections,
TypeSynonymInstances #-}
-----------------------------------------------------------------------------
{- |
Module: System.Console.StructuredCLI
Description: Application library for building interactive console CLIs
Copyright: (c) Erick Gonzalez, 2017-2018
License: BSD3
Maintainer: erick@codemonkeylabs.de
This module provides the tools to build a complete "structured" CLI application, similar
to those found in systems like Cisco IOS or console configuration utilities etc. It aims
to be easy for implementors to use.
-}
module System.Console.StructuredCLI (
-- * How to use this module:
-- |
-- It is often the case that a simple example is the best user guide, at least for the
-- experienced programmer. The following code illustrates a basic but functioning CLI application
--
-- @
-- module Main where
--
-- import Control.Monad (void)
-- import Control.Monad.IO.Class (liftIO)
-- import Data.Default (def)
-- import System.Console.StructuredCLI
--
-- root :: Commands ()
-- root = do
-- world >+ do
-- hello
-- bye
-- command "exit" "return to previous level" exit
--
-- world :: Commands ()
-- world = command "world" "enter into the world" $ return NewLevel
--
-- hello :: Commands ()
-- hello = command "hello" "prints a greeting" $ do
-- liftIO . putStrLn $ "Hello world!"
-- return NoAction
--
-- bye :: Commands ()
-- bye = command "bye" "say goodbye" $ do
-- liftIO . putStrLn $ "Sayonara!"
-- return NoAction
--
-- main :: IO ()
-- main = void $ runCLI "Hello CLI" def root
-- @
--
-- resulting example CLI session:
--
-- >>> Hello CLI > ?
-- - world: enter into the world
--
-- >>> Hello CLI > world
-- >>> Hello CLI world > ?
-- - exit: return to previous level
-- - bye: say goodbye
-- - hello: prints a greeting
--
-- >>> Hello CLI world > hello
-- Hello world!
-- >>> Hello CLI world > bye
-- Sayonara!
-- >>> Hello CLI world > exit
-- >>> Hello CLI >
--
-- A good way to get you started is to grab the example code available under <http://gitlab.com/codemonkeylabs/structured-cli/blob/master/example/Main.hs example/Main.hs> and modify it to suit your needs.
Action(..),
CLIException(..),
Commands,
CommandsT,
Handler,
Parser,
ParseResult(..),
Settings(..),
Validator,
(>+),
command,
command',
exit,
newLevel,
noAction,
param,
param',
runCLI,
top) where
import Control.Applicative (liftA2)
import Control.Monad (foldM, mapM, replicateM_, void, when)
import Control.Monad.Except (ExceptT(..), catchError, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.State.Strict (StateT, evalStateT, get, gets, modify, put)
import Data.Char (isSpace)
import Data.Default (Default, def)
import Data.List (intercalate, isPrefixOf, sort, span)
import Data.Monoid ((<>))
import System.Console.Haskeline (MonadException)
import qualified System.Console.Haskeline as HL
data State m = State { stack :: [ Level m ] }
type Level m = ( String, Node m )
type StateM m = StateT (State m) m
type Handler m = String -> m Action
-- | An 'Action' is returned as the result of a command handler provided by the user and
-- it instructs the CLI of any changes in the CLI state
data Action
-- | The command executed is "entered" into, creating a new CLI level.
= NewLevel
-- | Do not enter a new level.
| NoAction
-- | Reset the CLI state up to a given number of levels.
| LevelUp Int
-- | Go back up all the way to the top (root) of the CLI.
| ToRoot
deriving (Show)
data Node m = Node { getLabel :: String,
getHint :: String,
getBranches :: [Node m],
runParser :: Parser m,
isEnabled :: m Bool,
handle :: Handler m }
type Parser m = Node m -> String -> m ParseResult
-- | A 'Validator' is a function to which a parsed string is given in order to perform
-- any checks for validity that may be applicable, or even transforming the argument if
-- necessary. Note that the validator runs in the "user" monad
type Validator m = String -> m (Maybe String)
type ExceptionHandler m = CLIException -> m (Either CLIException ())
-- | There is no need to concern oneself with the 'ParseResult' type unless one is writing
-- a custom parser, which should actually be rarer than not.
data ParseResult =
Done {
-- | Output string to be fed to the command action handler
getOutput :: String,
-- | Part of the string matched during parsing of a command
getDoneMatched :: String,
-- | Remaining input data
getDoneRemaining :: String }
| Partial {
-- | List of possible completions after given input for this command
getCompletions :: [String],
-- | Remaining input data
getPartialRemaining :: String }
| Fail {
-- | A message string containing a possible hint for correct useage
getFailMessage :: String,
-- | Remaining input data
getFailRemaining :: String }
-- | Parsing provided input doesnt match this command. The difference between 'Fail' and
-- 'NoMatch' is a fine but important one. Failure should be used for example when a command
-- keyword is correct but a required parameter is invalid or contains an error for example.
-- A 'NoMatch' should be exclusively used when a command keyword does not correspond to the
-- given input
| NoMatch
deriving Show
data Settings m
-- | CLI Settings provided upon launching the CLI. It is recommended to modify
-- the settings provided by the 'Default' instance: i.e:
-- @
-- def { getBanner = "My CLI" }
-- @
-- that way you can use for example the default exception handler which should suit
-- usual needs, etc.
= Settings {
-- | An optional filename to activate and store the CLI command history function
getHistory :: Maybe FilePath,
-- | Text to display upon start of the CLI application
getBanner :: String,
-- | Prompt characters to display to the right of the current command "stack"
getPrompt :: String,
-- | Disable prompt for use with batch scripts
isBatch :: Bool,
-- | Exception handler
handleException :: ExceptionHandler m }
data CLIException = Exit
| InternalError String
| SyntaxError String
| UndecisiveInput String [String]
| HelpRequested [(String, String)]
| InvalidOperation String
deriving Show
-- | The 'CommandsT' transformer monad is the key to building a CLI tree. It is meant to
-- be used as a transformer wrapping an application specific "user" monad (for example, a 'State'
-- monad encapsulating application state). This monad is executed _once_ upon calling 'runCLI'
-- to build the command tree. Keep in mind however that any parsers or actions used in
-- any given command all run in the "user" monad and unlike the process of building the command
-- tree, they will be called multiple times as the user navigates the CLI at runtime.
-- Each 'CommandsT' monadic action corresponds to a single "node" (a.k.a. command) in the CLI.
-- Succesive actions simply add commands to the current "level". It is possible to "nest"
-- a new level to a command by using the '(>+)' operator. When properly indented (see example code
-- above) it provides a pretty self explanatory way to build the CLI tree.
newtype CommandsT m a = CommandsT { runCommandsT :: m (a, [Node m]) }
-- | An alias type for the case where CommandsT wraps IO only (i.e. no state, etc)
type Commands = CommandsT IO
instance (Functor f) => Functor (CommandsT f) where
fmap f = CommandsT . fmap (\(a, w) -> (f a, w)) . runCommandsT
instance (Applicative a) => Applicative (CommandsT a) where
pure = CommandsT . pure . (, mempty)
x <*> y = CommandsT $ liftA2 f (runCommandsT x) (runCommandsT y)
where f (a, v) (b, w) = (a b, v <> w)
instance (Monad m) => Monad (CommandsT m) where
return = pure
m >>= f = CommandsT $ do
(a, v) <- runCommandsT m
(b, w) <- runCommandsT $ f a
return $ (b, v <> w)
fail msg = CommandsT $ fail msg
instance MonadTrans CommandsT where
lift m = CommandsT $ do
a <- m
return (a, mempty)
instance (MonadIO m) => MonadIO (CommandsT m) where
liftIO = lift . liftIO
instance (MonadIO m) => Default (Settings m) where
def = Settings Nothing "" " > " False defExceptionHandler
instance (Monad m) => Default (Parser m) where
def = labelParser
instance (Monad m) => Default (Validator m) where
def = return . pure . id
type ParserT m = ExceptT CLIException (HL.InputT (StateM m))
liftStateM :: (Monad m) => StateM m a -> ParserT m a
liftStateM = lift . lift
liftInputT :: (Monad m) => HL.InputT (StateM m) a -> ParserT m a
liftInputT = lift
liftUserM :: (Monad m) => m a -> ParserT m a
liftUserM = lift . lift . lift
execCommandsT :: (Monad m) => CommandsT m a -> m [Node m]
execCommandsT = fmap snd . runCommandsT
-- | the CommandsT "nest" operation. It adds a new deeper CLI level to the command on the left
-- side with the commands on the right side, for example:
-- @
-- activate >+ do
-- foo
-- bar
-- baz
-- @
-- Would result in the following CLI command structure:
--
-- >>> > activate
-- >>> activate > ?
-- >>> - foo ..
-- >>> - bar ..
-- >>> - baz ..
(>+) :: (Monad m) => CommandsT m () -> CommandsT m () -> CommandsT m ()
node >+ descendents = do
node' <- lift $ execCommandsT node
case node' of
[] ->
error $ "Cannot branch off empty command"
_:_:_ ->
error $ "Cannot branch off more than one command"
[predecessor] ->
CommandsT $ do
ns <- execCommandsT descendents
return ((), [predecessor { getBranches = ns }])
-- | Build a command node that is always active and takes no parameters
command :: (Monad m) => String -- ^ Command keyword
-> String -- ^ Help text for this command
-> m Action -- ^ Action in the "user" monad (i.e. @return NewLevel@)
-> CommandsT m ()
command label hint action = do
command' label hint (return True) action
-- | A variation of 'command' that allows for "disabling" the command at runtime by
-- running the given "enable" monadic action (as always in the "user" monad) to check
-- if the command should be displayed as an option and/or accepted or not.
command' :: (Monad m) => String -- ^ Command keyword
-> String -- ^ Help text for this command
-> m Bool -- ^ Enable action in the "user" monad
-> m Action -- ^ Action in the "user" monad (i.e. @return NewLevel@)
-> CommandsT m ()
command' label hint enable action = do
let node = Node { getLabel = label,
getHint = hint,
getBranches = [],
runParser = labelParser,
isEnabled = enable,
handle = const action }
CommandsT . return $ ((), [node])
-- | Build a command node that takes one parameter (delimited by space). The parsed parameter
-- is fed to the validator monadic function (in the "user" monad) and the resulting string
-- if any is fed in turn as an argument to the handler action (also in the "user" monad).
param :: (Monad m) => String -- ^ Command keyword
-> String -- ^ Help text for this command (including argument description)
-> Validator m -- ^ Monadic validator (in the "user" monad)
-> Handler m -- ^ Action in the "user" monad (i.e. @return NewLevel@)
-> CommandsT m ()
param label hint validator handler =
param' label hint validator (return True) handler
-- | A variation of 'param' that allows for "disabling" the command at runtime by
-- running the given "enable" monadic action (as always in the "user" monad) to check
-- if the command should be displayed as an option and/or accepted or not.
param' :: (Monad m) => String -- ^ Command keyword
-> String -- ^ Help text for this command (including argument description)
-> Validator m -- ^ Monadic validator (in the "user" monad)
-> m Bool -- ^ Enable action in the "user" monad
-> Handler m -- ^ Action in the "user" monad (i.e. @return NewLevel@)
-> CommandsT m ()
param' label hint validator enable handler = do
let node = Node { getLabel = label,
getHint = hint,
getBranches = [],
runParser = paramParser hint validator,
isEnabled = enable,
handle = handler }
CommandsT . return $ ((), [node])
-- | A utility action to reset the CLI tree to the root node . Equivalent to @return ToRoot@
top :: (Monad m) => m Action
top = return ToRoot
-- | A utility action to "leave" the current CLI level. Equivalent to @return $ LevelUp 1@
exit :: (Monad m) => m Action
exit = return $ LevelUp 1
-- | A utility action to "nest" into a new CLI level. Equivalent to @return NewLevel@
newLevel :: (Monad m) => m Action
newLevel = return NewLevel
-- | A utility action to leave the current CLI level untouched. Equivalent to @return NoAction@
noAction :: (Monad m) => m Action
noAction = return NoAction
labelParser :: (Monad m) => Node m -> String -> m ParseResult
labelParser Node{..} input = do
case nextWord input of
(word, remaining) | word == getLabel ->
return $ Done "" word remaining
(word, remaining) | word `isPrefixOf` getLabel ->
return $ Partial [getLabel] remaining
(_, _) ->
return $ NoMatch
infixr 9 -.-
(-.-) :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
(-.-) = (.).(.)
paramParser :: (Monad m) => String -> (String -> m (Maybe String)) -> Node m -> String -> m ParseResult
paramParser hint validator = parseParam -.- labelParser
where parseParam = flip (>>=) parseParam'
parseParam' (Done _ matched rest) =
case nextWord rest of
("?", _) ->
return $ Fail hint rest
("", remaining) ->
return $ Partial [] remaining
(word, remaining) -> do
v <- validator word
return $ maybe (badArg rest) (\x -> Done x (matched ++ ' ':word) remaining) v
parseParam' result =
return result
badArg = Fail hint
nextWord :: String -> (String, String)
nextWord = span (not.isSpace) . dropWhile isSpace
hLineSettingsFrom :: (MonadIO m) => Settings m -> HL.Settings (StateM m)
hLineSettingsFrom Settings{..} =
HL.setComplete explorer HL.defaultSettings { HL.historyFile = getHistory }
-- | Launches the CLI application. It doesn't normally return unless an exception is thrown
-- or if it runs out of input in batch mode. Normal return value is that returned by the CommandsT
-- action that built the tree. Remember that 'Settings' is an instance of 'Default'
runCLI :: (MonadException m) => String -> Settings m -> CommandsT m a -> m (Either CLIException a)
runCLI name settings@Settings{..} commands = do
(value, root) <- runCommandsT commands
when (not isBatch) $ liftIO . putStrLn $ getBanner
let ?settings = settings
withStateM root . HL.runInputT hLineSettings . runExceptT $ do
loop
return value
where hLineSettings = hLineSettingsFrom settings
withStateM root = flip evalStateT $ state0 root
processInput = do
let ?settings = settings
state <- liftStateM get
runLevel `catchError` \e -> do
liftStateM $ put state
throwError e
processInput
dummyParser' _ t = return . (flip Partial) t . fmap getLabel
dummyParser r s t = dummyParser' s t r
state0 root = State [(name, mkNode root)]
mkNode root = Node {
getLabel = name,
getHint = mempty,
getBranches = root,
runParser = dummyParser root,
isEnabled = return True,
handle = const . return $ NewLevel
}
loop = do
void . catchError processInput $
\e -> do
exceptionResult <- liftUserM $ handleException e
either throwError return exceptionResult
loop
defExceptionHandler :: (MonadIO m) => CLIException -> m (Either CLIException ())
defExceptionHandler (SyntaxError str) = do
fmap Right . liftIO . putStrLn $ "SyntaxError at or around " ++ str ++ "\n"
defExceptionHandler (HelpRequested hints) =
fmap Right . liftIO $ do
mapM_ display $ hints
putStrLn ""
where display (label, hint) =
putStrLn $ "- " ++ label ++ ": " ++ hint
defExceptionHandler e =
return . Left $ e
runLevel :: (?settings::Settings m, MonadException m) => ParserT m ()
runLevel = do
prompt <- buildPrompt <$> withLabels
stack0 <- getStack
result <- runMaybeT $ do
line <- MaybeT . liftInputT $ HL.getInputLine prompt
process line
case result of
Nothing ->
if isBatch ?settings
then throwError Exit
else restore stack0
_ ->
return ()
where buildPrompt ns = (intercalate " " . reverse $ ns) ++ getPrompt ?settings
withLabels = getStack >>= return . fmap fst
restore stack = liftStateM . modify $ \s -> s { stack = stack }
getStack :: (Monad m) => ParserT m [Level m]
getStack = liftStateM $ gets stack
process :: (Monad m) => String -> MaybeT (ParserT m) ()
process input = lift $ do
stack0 <- getStack
node <- getCurrentNode
action <- process' input node NewLevel -- I believe it shouldn't actually matter since it will
-- simply be overriden by the last action result but
-- NewLevel als default action is correct in term of the
-- expected behaviour when parsing a command. We keep
-- nesting until done..
case action of
NewLevel ->
return ()
LevelUp n ->
levelUp n stack0
NoAction ->
levelUp 0 stack0
ToRoot ->
levelUp (-maxBound) stack0
where levelUp levels stack0 = do
stack <- getStack
let depth = length stack
depth0 = length stack0
depth' = max 1 $ depth0 - levels -- there must always be at least a root node
to = depth - depth'
replicateM_ to pop
process' :: (Monad m) => String -> Node m -> Action -> ParserT m Action
process' "" _ action =
return action
process' (' ':remaining) node action =
process' remaining node action
process' input currentNode _ = do
result <- liftStateM $ findNext currentNode input
case result of
([], _, _, _) ->
throwError . SyntaxError $ input
([node@Node{..}], output, matched, remaining) -> do
checkForHelp matched [node]
push matched node
action <- liftUserM $ handle output
process' remaining node action
(nodes, _, matched, _) -> do
checkForHelp matched nodes
throwError . UndecisiveInput input $ fmap getLabel nodes
where checkForHelp "?" nodes =
void . throwError . HelpRequested $ fmap help nodes
checkForHelp _ _ =
return ()
help :: (Monad m) => Node m -> (String , String)
help Node{..} = (getLabel, getHint)
push :: (Monad m) => String -> Node m -> ParserT m ()
push label node =
liftStateM . modify $ \s@State{..} ->
s { stack = (label, node) : stack }
pop :: (Monad m) => ParserT m ()
pop = do
stack <- liftStateM $ gets stack
case stack of
(_:remaining) ->
liftStateM $ modify $ \s -> s { stack = remaining }
[] ->
throwError . InvalidOperation $ "Invalid attempt to pop element from empty command stack"
getCurrentNode :: (Monad m) => ParserT m (Node m)
getCurrentNode = do
stack <- liftStateM $ gets stack
case stack of
((_, node):_) -> return node
[] -> throwError . InternalError $ "Empty command stack"
findNext :: (Monad m) => Node m -> String -> StateM m ([Node m], String, String, String)
findNext = findNext' False
findAll :: (Monad m) => Node m -> String -> StateM m ([Node m], String, String, String)
findAll = findNext' True
findNext' :: (Monad m) => Bool -> Node m -> String -> StateM m ([Node m], String, String, String)
findNext' wantsPartial root input = do
(nodes, output, matched, remaining, _isDone) <- foldM matching ([], "", "", input, False) branches
return (nodes, output, matched, remaining)
where matching acc@(nodes, "", _, remaining, False) node@Node{..} = do
enabled <- lift isEnabled
if enabled then
case nextWord remaining of
(q@"?", _) ->
return (node:nodes, "", q, remaining, False)
_ -> do
result <- lift $ runParser node remaining
case result of
Done output matched rest ->
return ([node], output, matched, rest, True)
Fail _ rest ->
case nextWord rest of
(q@"?", _) ->
return ([node], "", q, rest, True)
_ ->
return acc
Partial _ remaining' ->
if wantsPartial
then return (node:nodes, "", "", remaining', False)
else return acc
NoMatch ->
return acc
else
return acc
matching acc _ = return acc -- short circuit out of the fold if output is not empty
branches = getBranches root
explorer :: (Monad m) => HL.CompletionFunc (StateM m)
explorer input@(tfel, _) = do
currentLevel <- gets stack
possibilities <- case currentLevel of
(_, currentNode):_ ->
sort <$> getPossibilities currentNode left
_ ->
return []
let complete = HL.completeWord Nothing " " $ \str ->
return $ map HL.simpleCompletion $ filter (str `isPrefixOf`) possibilities
complete input
where left = reverse tfel
getPossibilities :: (Monad m) => Node m -> String -> StateM m [String]
getPossibilities root input = do
result <- findAll root input
case result of
([node], _, _, "") -> do
result' <- lift $ runParser root node input
case result' of
Done _ _ _ ->
return [" "] -- perfect match - complete with space
Partial possibilities _ ->
return possibilities
_ ->
return []
([node], _, _, remaining) ->
getPossibilities node remaining
([], _, _, _) ->
return []
(nodes, _, _, _) -> do
concat <$> mapM getPossibility nodes
where getPossibility node@Node{..} = do
result' <- lift $ runParser node input
case result' of
Partial matches _ ->
return matches
_ ->
return []