structured-cli-2.7.0.0: src/System/Console/StructuredCLI.hs
{-# LANGUAGE CPP,
ImplicitParams,
ExistentialQuantification,
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,
Node,
Parser,
ParseResult(..),
Settings(..),
Validator,
(>+),
command,
command',
custom,
exit,
isCompleted,
isIncomplete,
isNoResult,
isFailed,
labelParser,
newLevel,
noAction,
param,
param',
paramParser,
parseOneOf,
runCLI,
top) where
import Control.Applicative (liftA2)
import Control.Monad (replicateM_, void, when)
import Control.Monad.Catch (MonadMask)
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)
import qualified System.Console.Haskeline as HL
#ifdef __DEBUG__
import Debug.Trace
debugM :: (Applicative f) => String -> f ()
debugM = traceM
#else
debugM :: (Applicative f) => String -> f ()
debugM _ = pure ()
#endif
data State m = State { stack :: [ Level m ] }
type Level m = ( String, Node m )
type StateM m = StateT (State m) m
type Handler m a = a -> 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)
-- | The 'Node' type contains the internal representation of a command. Normally there is no
-- need to be concerned with it other than perhaps passing it opaquely to any utility parsers
-- (like 'labelParser' for example), when writing a custom parser
data Node m = forall a . Node {
getLabel :: String,
getHint :: String,
getBranches :: [Node m],
runParser :: Parser m a,
isEnabled :: m Bool,
handle :: Handler m a }
type Parser m a = Node m -> String -> m (ParseResult a)
-- | 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 a = String -> m (Maybe a)
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 a =
Done {
-- | Output (parsed) value to be fed to the command action handler
getOutput :: a,
-- | Part of the string matched during parsing of a command
getDoneMatched :: String,
-- | Remaining input data
getDoneRemaining :: String }
| Partial {
-- | List of possible completions along with a corresponding help string
getPartialHints :: [(String, 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 :: m String,
-- | Disable prompt for use with batch scripts
isBatch :: Bool,
-- | Exception handler
handleException :: ExceptionHandler m }
data CLIException = Exit
| InternalError String
| SyntaxError String 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)
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 "" (return " > ") False defExceptionHandler
instance (Monad m) => Default (Parser m String) where
def = labelParser
instance (Monad m) => Default (Validator m String) where
def = return . pure
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
data SearchResult m = Completed { completedNode :: Node m,
completedAction :: m Action,
completedMatched :: String,
completedRemaining :: String }
| Incomplete { incompleteNode :: Node m,
incompleteHints :: [(String, String)] }
| Failed { failedNode :: Node m,
failedMsg :: String,
failedRemaining :: String }
| NoResult
isCompleted :: (Monad m) => SearchResult m -> Bool
isCompleted Completed{..} = True
isCompleted _ = False
isIncomplete :: (Monad m) => SearchResult m -> Bool
isIncomplete Incomplete{..} = True
isIncomplete _ = False
isNoResult :: (Monad m) => SearchResult m -> Bool
isNoResult NoResult = True
isNoResult _ = False
isFailed :: (Monad m) => SearchResult m -> Bool
isFailed Failed{..} = True
isFailed _ = False
-- | 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
custom label hint labelParser enable $ const action
-- | 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 value
-- 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 a -- ^ Monadic validator (in the "user" monad)
-> Handler m a -- ^ Handling action. Takes the validator output as argument
-> 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 a -- ^ Monadic validator (in the "user" monad)
-> m Bool -- ^ Enable action in the "user" monad
-> Handler m a -- ^ Handling action. Takes the validator output as argument
-> CommandsT m ()
param' label hint validator enable handler = do
custom label hint parser enable handler
where parser = paramParser hint validator
-- | Create a command using a custom parser, providing thus complete flexibility
custom :: (Monad m) => String -- ^ Command keyword
-> String -- ^ Help text for this command
-> Parser m a -- ^ Custom parser (runs in the "user" monad)
-> m Bool -- ^ Enable action in the "user" monad
-> Handler m a -- ^ Handling action. Takes the validator output as argument
-> CommandsT m ()
custom label hint parser enable handler = do
let node = Node { getLabel = label,
getHint = hint,
getBranches = [],
runParser = parser,
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
-- | A utility parser that reads an input and parses a command label. It can be used as part of
-- custom parsers to first read the command keyword before parsing any arguments etc.
labelParser :: (Monad m) => Node m -> String -> m (ParseResult String)
labelParser Node{..} input = do
case nextWord input of
("?", remaining) ->
return $ Fail getHint remaining
(word, remaining) | word == getLabel ->
return $ Done "" word remaining
(word, remaining) | word `isPrefixOf` getLabel ->
return $ Partial [(getLabel, getHint)] remaining
(_, _) ->
return $ NoMatch
infixr 9 -.-
(-.-) :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
(-.-) = (.).(.)
-- | A utility parser that reads an input and parses any of the provided possibilities
-- as a parameter for the command node using this parser (see provided example.hs)
parseOneOf :: (Monad m) => [String] -> String-> Node m -> String -> m (ParseResult String)
parseOneOf possibilities hint = parseOneOf' -.- labelParser
where parseOneOf' = (=<<) parseOneOf''
parseOneOf'' :: (Monad m) => ParseResult String -> m (ParseResult String)
parseOneOf'' (Done _ _ rest) =
case nextWord rest of
("?", _) ->
return $ Fail hint rest
("", remaining) ->
return $ Partial (zip possibilities $ repeat "") remaining
(word, _) -> do
results <- mapM (parseOne word) (zip possibilities $ repeat "")
case filter isDone results of
(Done _ matched remaining:_) -> return $ Done matched matched remaining
_ ->
case filter isPartial results of
[] ->
case results of
(result':_) -> return result'
_ -> return NoMatch
partials ->
return $ foldl merge (Partial [] "") partials
parseOneOf'' (Fail hint' rest) = return $ Fail hint' rest
parseOneOf'' (Partial xs rest) = return $ Partial xs rest
parseOneOf'' NoMatch = return NoMatch
merge (Partial ps _) (Partial ps' rest') = Partial (ps ++ ps') rest'
merge _ _ = error "Internal inconsistency merging partial results from parseOneOf"
isDone (Done _ _ _) = True
isDone _ = False
isPartial (Partial _ _) = True
isPartial _ = False
parseOne input (str, hint') = labelParser Node { getLabel = str,
getHint = hint',
getBranches = [],
isEnabled = return True,
runParser = error "dummy parser",
handle = const $ return NoAction
} input
paramParser :: Monad m => String -> (String -> m (Maybe a)) -> Node m -> String -> m (ParseResult a)
paramParser hint validator = parseParam -.- labelParser
where parseParam = (=<<) parseParam'
parseParam' (Done _ matched rest) =
case nextWord rest of
("?", _) ->
return $ Fail hint rest
("", remaining) ->
return $ Partial [("", hint)] remaining
(word, remaining) -> do
v <- validator word
return $ maybe (badArg rest) (\x -> Done x (matched ++ ' ':word) remaining) v
parseParam' (Fail x y) =
return $ Fail x y
parseParam' (Partial x y) =
return $ Partial x y
parseParam' NoMatch = return NoMatch
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 :: (MonadMask m, MonadIO m, HL.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 _ = \_ input ->
return $ Partial [] input
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 msg) = do
fmap Right . liftIO . putStrLn $ "SyntaxError at or around " ++ str ++ ": " ++ msg ++ "\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, MonadMask m, MonadIO m, HL.MonadException m)
=> ParserT m ()
runLevel = do
prompt <- liftUserM . buildPrompt =<< withLabels
stack0 <- getStack
result <- runMaybeT $ do
line <- MaybeT . liftInputT $ HL.getInputLine prompt
when (isBatch ?settings) $ printInput line
process line
case result of
Nothing ->
if isBatch ?settings
then throwError Exit
else restore stack0
_ ->
return ()
where buildPrompt ns = (showStack ns ++) <$> getPrompt ?settings
withLabels = fmap fst <$> getStack
restore stack = liftStateM . modify $ \s -> s { stack = stack }
showStack = intercalate " " . reverse
printInput = lift . liftInputT . HL.outputStrLn
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
debugM $ "processing " ++ show input ++ " on " ++ getLabel currentNode
result <- liftStateM $ findNext currentNode input
case filter isCompleted result of
(Completed{ completedNode=node@Node{..}, ..}:_) -> do
push completedMatched node
action <- liftUserM completedAction
process' completedRemaining node action
_ ->
if checkForHelp . dropWhile isSpace $ reverse input then do
let hints = foldl getHelp [] result
debugM $ "help requested: " ++ show hints
throwError . HelpRequested $ hints
else
case filter isFailed result of
Failed{..}:_ ->
throwError . SyntaxError input $ failedMsg
_ ->
case filter isIncomplete result of
Incomplete{..}:_ ->
throwError . SyntaxError input . snd . head $ incompleteHints
_ ->
throwError . SyntaxError input $ ""
where checkForHelp ('?':_) = True
checkForHelp _ = False
getHelp acc Failed{..} = (getLabel failedNode, failedMsg):acc
getHelp acc Incomplete{..} = incompleteHints ++ acc
getHelp acc Completed{..} = help completedNode : acc
getHelp acc _ = acc
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 [SearchResult m]
findNext root input = do
filter (not . isNoResult) <$> mapM matching branches
where matching node@Node{..} = do
enabled <- lift isEnabled
if enabled then do
result <- lift $ runParser node input
case result of
Done output matched rest ->
return Completed { completedNode = node,
completedAction = handle output,
completedMatched = matched,
completedRemaining = rest }
Fail msg rest ->
return Failed { failedNode = node,
failedMsg = msg,
failedRemaining = rest }
Partial hints _ ->
return Incomplete { incompleteNode = node,
incompleteHints = hints }
NoMatch ->
return NoResult
else
return NoResult
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
results <- findNext root input
case filter isCompleted results of
(_:_:_) ->
return []
Completed{..}:[] ->
getPossibilities completedNode completedRemaining
_ ->
return $ fst <$> foldl getPossibilities' [] results
where getPossibilities' acc Incomplete{..} = filter notEmpty incompleteHints ++ acc
getPossibilities' acc _ = acc
notEmpty ("", _) = False
notEmpty (_, _) = True