diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,12 +1,9 @@ {-# LANGUAGE RecordWildCards, FlexibleContexts #-} module Main where -import Control.Monad.Trans (lift) import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (StateT, evalStateT, gets, modify) -import Data.Char (isSpace) import Data.Default (def) -import Data.List (span) import System.Console.StructuredCLI import Text.Read (readMaybe) @@ -22,52 +19,51 @@ basic :: CommandsT StateM () basic = do - top $ Just "return to the top of the tree" - exit $ Just "go back one level up" + command "top" "return to the top of the tree" top + command "exit" "go back one level up" exit foo :: CommandsT StateM () foo = - command "foo" (Just "pity the foo") Nothing >+ do + command "foo" "pity the foo" (return NewLevel) >+ do basic bar baz bar :: CommandsT StateM () -bar = param "bar" (Just "") parseBars Nothing >+ do +bar = param "bar" "" parseBars setBars >+ do basic frob + where setBars str = do + let b = read str + bars <- gets bars + modify $ \s -> s { bars = bars + b } + return NewLevel baz :: CommandsT StateM () -baz = command "baz" (Just "do the baz thing") $ Just $ do - n <- lift $ modify incBaz >> gets bazs +baz = command' "baz" "do the baz thing" checkBazs $ do + n <- modify incBaz >> gets bazs liftIO . putStrLn $ "You have bazzed " ++ show n ++ " times" - return 0 + return NoAction where incBaz s@AppState{..} = s { bazs = bazs + 1 } + checkBazs = do + bazCount <- gets bazs + return $ bazCount < 3 -- after 3 bazs, disable baz command frob :: CommandsT StateM () -frob = command "frob" (Just "frob this level") $ Just $ do - n <- lift $ gets bars +frob = command "frob" "frob this level" $ do + n <- gets bars liftIO . putStrLn $ "frobbing " ++ show n ++ " bars" - return 0 - -parseBars :: Parser StateM -parseBars = mkParser $ readNum "bar" - -readNum :: String -> Bool -> String -> StateM ParseResult -readNum name _ "" = return $ failure name -readNum name _ input = do - let (x, remains) = span (not.isSpace) $ dropWhile isSpace input - maybe (complain) (accept x remains) $ readMaybe x - where complain = do - return $ failure name - accept x remaining n = do - modify $ \s@AppState{..} -> s { bars = n } - return $ Done x remaining + return NoAction -failure :: String -> ParseResult -failure name = Fail name $ Just "" +parseBars :: Validator StateM +parseBars = return . fmap show . (readMaybe :: String -> Maybe Int) main :: IO () -main = evalStateT (runCLI "some CLI" (Just settings) root) $ AppState 0 0 - where settings = def { banner = "Some CLI Application\nTab completion is your friend!", - history = Just ".someCLI.history" } +main = do + let state0 = AppState 0 0 + evalStateT run state0 + where run = do + result <- runCLI "some CLI" settings root + either (error.show) return result + settings = def { getBanner = "Some CLI Application\nTab completion is your friend!", + getHistory = Just ".someCLI.history" } diff --git a/src/System/Console/StructuredCLI.hs b/src/System/Console/StructuredCLI.hs --- a/src/System/Console/StructuredCLI.hs +++ b/src/System/Console/StructuredCLI.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE ImplicitParams, RecordWildCards, TupleSections #-} +{-# LANGUAGE ImplicitParams, + FlexibleContexts, + FlexibleInstances, + RecordWildCards, + TupleSections, + TypeSynonymInstances #-} ----------------------------------------------------------------------------- {- | Module: System.Console.StructuredCLI Description: Application library for building interactive console CLIs -Copyright: (c) Erick Gonzalez, 2017 +Copyright: (c) Erick Gonzalez, 2017-2018 License: BSD3 Maintainer: erick@codemonkeylabs.de @@ -15,11 +20,15 @@ module System.Console.StructuredCLI ( -- * How to use this module: -- | --- The following code illustrates a simple but complete --- CLI app: +-- 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 -- -- @ --- import Control.Monad.IO.Class (liftIO) +-- module Main where +-- +-- import Control.Monad (void) +-- import Control.Monad.IO.Class (liftIO) +-- import Data.Default (def) -- import System.Console.StructuredCLI -- -- root :: Commands () @@ -27,121 +36,187 @@ -- world >+ do -- hello -- bye --- exit $ Just "return to previous level" +-- command "exit" "return to previous level" exit -- -- world :: Commands () --- world = command "world" (Just "enter into world") Nothing +-- world = command "world" "enter into the world" $ return NewLevel -- -- hello :: Commands () --- hello = command "hello" (Just "prints a greeting") $ Just $ do +-- hello = command "hello" "prints a greeting" $ do -- liftIO . putStrLn $ "Hello world!" --- return 0 +-- return NoAction -- -- bye :: Commands () --- bye = command "bye" (Just "say goodbye") $ Just $ do +-- bye = command "bye" "say goodbye" $ do -- liftIO . putStrLn $ "Sayonara!" --- return 0 +-- return NoAction -- -- main :: IO () --- main = runCLI "Hello CLI" Nothing root +-- main = void $ runCLI "Hello CLI" def root -- @ -- --- resulting example session: +-- resulting example CLI session: -- -- >>> Hello CLI > ? --- - world: enter into world +-- - world: enter into the world +-- -- >>> Hello CLI > world --- >>> Hello CLI world > --- bye exit hello +-- >>> 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 and modify it to suit your needs. - Action, +-- A good way to get you started is to grab the example code available under and modify it to suit your needs. + Action(..), + CLIException(..), Commands, - CommandsT(..), + CommandsT, + Handler, Parser, ParseResult(..), Settings(..), - State(..), + Validator, (>+), command, command', exit, - mkParser, - outputStrLn, + newLevel, + noAction, param, param', - popCommand, - pushCommand, runCLI, top) where import Control.Applicative (liftA2) -import Control.Exception (Exception, throw) -import Control.Monad (filterM, foldM, replicateM, void, when) +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, gets, modify) ---import Data.Attoparsec.ByteString (Parser, --- Result, --- parse, --- string) +import Control.Monad.State.Strict (StateT, evalStateT, get, gets, modify, put) import Data.Char (isSpace) import Data.Default (Default, def) -import Data.IORef (IORef, readIORef) -import Data.List (filter, isPrefixOf, intercalate, span, sort) -import Data.Maybe (isJust, fromJust) +import Data.List (intercalate, isPrefixOf, sort, span) import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import System.Console.Haskeline (Completion, - InputT, - MonadException, - completeWord, - defaultSettings, - getInputLine, - outputStrLn, - runInputT, - setComplete, - simpleCompletion) +import System.Console.Haskeline (MonadException) -import qualified System.Console.Haskeline as Haskeline +import qualified System.Console.Haskeline as HL -data State m = State { nodes :: [Node m], - labels :: [String] } +data State m = State { stack :: [ Level m ] } -type CState m = StateT (State m) m -type Action m = CState m Int +type Level m = ( String, Node m ) -data Node m = Node { label :: String, - hint :: Maybe String, - disable :: Maybe (IORef Bool), - branches :: [Node m], - parser :: Parser m, - action :: Maybe (Action m) } +type StateM m = StateT (State m) m -data Settings = Settings { history :: Maybe FilePath, - banner :: String, - prompt :: String, - batch :: Bool } +type Handler m = String -> m Action -data CLIException = Exit deriving (Show, Typeable) +-- | 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) -instance Exception CLIException +data Node m = Node { getLabel :: String, + getHint :: String, + getBranches :: [Node m], + runParser :: Parser m, + isEnabled :: m Bool, + handle :: Handler m } -newtype CommandsT m a = CommandsT { runCommandsT :: m (a, [Node m]) } -type Commands = CommandsT IO +type Parser m = Node m -> String -> m ParseResult -newtype Parser m = Parser { runParser :: (Bool -> 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) -data ParseResult = Done String String - | Fail String (Maybe String) - | Options String [String] - | Partial - deriving Show +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 @@ -166,70 +241,44 @@ instance (MonadIO m) => MonadIO (CommandsT m) where liftIO = lift . liftIO -instance (MonadIO m) => Default (Parser m) where - def = Parser labelParser - -instance Default Settings where - def = Settings Nothing "" " > " False - -nextWord :: String -> (String, String) -nextWord = span (not.isSpace) . dropWhile isSpace +instance (MonadIO m) => Default (Settings m) where + def = Settings Nothing "" " > " False defExceptionHandler -trim :: String -> String -trim = reverse.dropWhile isSpace.reverse +instance (Monad m) => Default (Parser m) where + def = labelParser -labelParser :: (MonadIO m) => Bool -> Node m -> String -> m ParseResult -labelParser _ Node{..} "" = return $ Fail ("Missing expected keyword " ++ label) hint -labelParser partial Node{..} input = do - let (x, remains) = nextWord input - let result = if label == x then - Done x remains - else do - failure x - return result - where failure x | partial = if x `isPrefixOf` label then Partial else failed - | otherwise = failed - failed = Fail label hint +instance (Monad m) => Default (Validator m) where + def = return . pure . id -noParse :: (Monad m) => Parser m -noParse = Parser . const . const . const . return $ Fail "" Nothing +type ParserT m = ExceptT CLIException (HL.InputT (StateM m)) -command :: (MonadIO m) - => String - -> Maybe String - -> Maybe (Action m) - -> CommandsT m () -command name hint action = - CommandsT . return . ((),) . pure $ Node name hint Nothing [] def action +liftStateM :: (Monad m) => StateM m a -> ParserT m a +liftStateM = lift . lift -param :: (Monad m) - => String - -> Maybe String - -> Parser m - -> Maybe (Action m) - -> CommandsT m () -param name hint parser action = - CommandsT . return . ((),) . pure $ Node name hint Nothing [] parser action +liftInputT :: (Monad m) => HL.InputT (StateM m) a -> ParserT m a +liftInputT = lift -command' :: (MonadIO m) - => String - -> Maybe String - -> Maybe (IORef Bool) - -> Maybe (Action m) - -> CommandsT m () -command' name hint disable action = - CommandsT . return . ((),) . pure $ Node name hint disable [] def action +liftUserM :: (Monad m) => m a -> ParserT m a +liftUserM = lift . lift . lift -param' :: (Monad m) - => String - -> Maybe String - -> Maybe (IORef Bool) - -> Parser m - -> Maybe (Action m) - -> CommandsT m () -param' name hint disable parser action = - CommandsT . return . ((),) . pure $ Node name hint disable [] parser action +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 @@ -241,236 +290,335 @@ [predecessor] -> CommandsT $ do ns <- execCommandsT descendents - return ((), [predecessor { branches = ns }]) + return ((), [predecessor { getBranches = ns }]) -execCommandsT :: (Monad m) => CommandsT m a -> m [Node m] -execCommandsT = fmap snd . runCommandsT +-- | 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 -exit :: (MonadIO m) => Maybe String -> CommandsT m () -exit hint = command "exit" hint $ Just $ do - ns <- gets nodes - case ns of - [] -> - lostInSpace - _:[] -> - lostInSpace - [_, _] -> do -- only 1 command left in the stack.. (should be root) - liftIO $ putStrLn "Nowhere else to go. Type anytime to exit" - return 0 - _ -> - return 1 -- pop 1 command from the stack +-- | 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]) -top :: (MonadIO m) => Maybe String -> CommandsT m () -top hint = command "top" hint $ Just $ return (-maxBound) +-- | 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 -runCLI :: (MonadException m) => String -> Maybe Settings -> CommandsT m () -> m () -runCLI name userSettings rootCmds = do - root <- execCommandsT rootCmds - settings <- runMaybeT $ do - s@Settings{..} <- MaybeT . pure $ userSettings - when (not batch) $ liftIO . putStrLn $ banner - return s - let ?settings = maybe def id settings - evalStateT loop $ stateFor root - where stateFor root = State [Node name Nothing Nothing root noParse Nothing] [name] - loop :: (?settings::Settings, MonadException m) => CState m () - loop = do - settings <- getSettings $ history ?settings - runInputT settings runLevel - loop +-- | 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]) -runLevel :: (?settings::Settings, MonadException m) => InputT (CState m) () -runLevel = do - prompt <- if batch ?settings then return "" else lift getPrompt - nodes0 <- lift $ gets nodes - labels0 <- lift $ gets labels - result <- runMaybeT $ do - line <- MaybeT $ getInputLine prompt - parse line - case result of - Nothing -> do - if batch ?settings then - throw Exit - else - lift $ modify $ \state -> state { nodes = nodes0, -- parse failed or no action - labels = labels0 } -- restore nodes to previous state - Just _ -> do - Node{..} <- lift getCurrentCommand - case action of - Nothing -> return () - Just x -> lift $ do - nodes <- gets nodes - popDepth <- x - let depth = length nodes - depth0 = length nodes0 - depth' = max 1 $ depth0 - popDepth -- there must always be at least a root node - toPop = depth - depth' - void $ replicateM toPop popCommand +-- | A utility action to reset the CLI tree to the root node . Equivalent to @return ToRoot@ +top :: (Monad m) => m Action +top = return ToRoot -parse :: (MonadIO m) => String -> MaybeT (InputT (CState m)) [Node m] -parse "" = currentBranches'' -parse ws | all isSpace ws = currentBranches'' -parse input = do - nodes <- currentBranches'' - (n@Node{..}, matched, remaining) <- findNode input nodes [Nothing] - lift $ pushCommand' n $ trim matched - parse remaining +-- | A utility action to "leave" the current CLI level. Equivalent to @return $ LevelUp 1@ +exit :: (Monad m) => m Action +exit = return $ LevelUp 1 -tryParse :: (MonadIO m) => String -> [Node m] -> m [Node m] -tryParse "" (x:_) = return $ branches x -tryParse _ [] = return [] -tryParse " " (x:_) = return $ branches x -tryParse input (n:_) = do - let nodes = branches n - result <- findNode' input nodes - case result of - Nothing -> - filterNodes input nodes - Just (c, remaining) -> do - tryParse remaining (c:nodes) +-- | A utility action to "nest" into a new CLI level. Equivalent to @return NewLevel@ +newLevel :: (Monad m) => m Action +newLevel = return NewLevel -filterNodes :: (MonadIO m) => String -> [Node m] -> m [Node m] -filterNodes input = foldM filterNodes' [] - where filterNodes' acc node@Node{..} = do - disabled <- liftIO $ maybe (return False) readIORef disable - if disabled - then return acc - else do - result <- runParser parser True node input - case result of - Fail _ _ -> - return acc - Options _ strs -> do - let nodes = fakeNode node <$> strs - return $ nodes ++ acc - _ -> - return $ node:acc +-- | A utility action to leave the current CLI level untouched. Equivalent to @return NoAction@ +noAction :: (Monad m) => m Action +noAction = return NoAction -currentBranches :: (MonadIO m) => (CState m) [Node m] -currentBranches = getCurrentCommand >>= return . branches +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 -currentBranches'' :: (MonadIO m, - MonadTrans t, - MonadTrans u, - Monad (u (CState m))) => - t (u (CState m)) [Node m] -currentBranches'' = lift . lift $ currentBranches +infixr 9 -.- +(-.-) :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c +(-.-) = (.).(.) -findNode :: (MonadIO m) => - String -> - [Node m] -> - [Maybe ParseResult] -> - MaybeT (InputT (CState m)) (Node m, String, String) -findNode input [] results = do - lift $ when (not $ "?" `isPrefixOf` reverse input) $ - outputStrLn $ "Syntax error at or around " ++ input - let (keyword,_) = nextWord $ reverse $ dropWhile (== '?') $ reverse input - lift $ mapM_ (outputStrLn.syntaxError) $ filter (matching keyword) results - MaybeT . return $ Nothing - where syntaxError (Just (Fail name hint)) = "- " ++ name ++ (maybe "" (": "++) hint) - syntaxError _ = "" - matching kw (Just (Fail name _)) = kw `isPrefixOf` name - matching _ _ = False -findNode input (node@Node{..}:rest) results = do - disabled <- liftIO $ maybe (return False) readIORef disable - if disabled - then findNode input rest results - else do - result <- lift . lift .lift $ (runParser parser) False node input - case result of - Done matched remaining -> - return (node, matched, remaining) - Partial -> - error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label - _ -> - findNode input rest $ (Just result):results +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 -findNode' :: (MonadIO m) => String -> [Node m] -> m (Maybe (Node m, String)) -findNode' _ [] = return Nothing -findNode' input (node@Node{..}:rest) = do - disabled <- liftIO $ maybe (return False) readIORef disable - if disabled - then findNode' input rest - else do - result <- (runParser parser) False node input - case result of - Done _ remaining -> - return $ Just (node, remaining) - Options input' strs -> do - let nodes = fakeNode node <$> strs - findNode' input' nodes - Partial -> - error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label - _ -> - findNode' input rest +nextWord :: String -> (String, String) +nextWord = span (not.isSpace) . dropWhile isSpace -fakeNode :: (MonadIO m) => Node m -> String -> Node m -fakeNode node str = node { label = str, parser = Parser labelParser } +hLineSettingsFrom :: (MonadIO m) => Settings m -> HL.Settings (StateM m) +hLineSettingsFrom Settings{..} = + HL.setComplete explorer HL.defaultSettings { HL.historyFile = getHistory } -pushCommand' :: (MonadTrans t, Monad m) => Node m -> String -> t (CState m) () -pushCommand' n = lift . pushCommand n +-- | 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 -pushCommand :: (Monad m) => Node m -> String -> CState m () -pushCommand n label = do - ns <- gets nodes - ls <- gets labels - modify $ \state -> state { nodes = n:ns, labels = label:ls } +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 -popCommand :: (Monad m) => CState m () -popCommand = do - (_:cs) <- gets nodes - (_:ls) <- gets labels - modify $ \state -> state { nodes = cs, labels = ls } +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 () -getSettings :: (MonadIO m) => Maybe FilePath -> CState m (Haskeline.Settings (CState m)) -getSettings path = - return $ setComplete explorer defaultSettings { Haskeline.historyFile = path } + where buildPrompt ns = (intercalate " " . reverse $ ns) ++ getPrompt ?settings + withLabels = getStack >>= return . fmap fst + restore stack = liftStateM . modify $ \s -> s { stack = stack } -explorer :: (MonadIO m) => (String, String) -> CState m (String, [Completion]) -explorer input@(left, _) = do - nodes <- gets nodes - options <- lift $ getPossibilities left nodes - let keywords = sort $ fmap label options - let complete = completeWord Nothing " " $ \str -> - return $ map simpleCompletion $ filter (str `isPrefixOf`) keywords - complete input +getStack :: (Monad m) => ParserT m [Level m] +getStack = liftStateM $ gets stack -getPossibilities :: (MonadIO m) => String -> [Node m] -> m [Node m] -getPossibilities "" = filterM checkDisabled . branches . head - where checkDisabled Node{..} - | isJust disable = do - isDisabled <- liftIO $ readIORef (fromJust disable) - return $ not isDisabled - | otherwise = return True -getPossibilities input = tryParse $ reverse input +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.. -getCurrentCommand :: (Monad m) => CState m (Node m) -getCurrentCommand = do - ns <- gets nodes - case ns of + 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 } [] -> - lostInSpace - node:_ -> - return node + throwError . InvalidOperation $ "Invalid attempt to pop element from empty command stack" -getPrompt :: (?settings::Settings, Monad m) => CState m String -getPrompt = buildPrompt <$> gets labels - where buildPrompt ns = (intercalate " " . reverse $ ns) ++ prompt ?settings +getCurrentNode :: (Monad m) => ParserT m (Node m) +getCurrentNode = do + stack <- liftStateM $ gets stack + case stack of + ((_, node):_) -> return node + [] -> throwError . InternalError $ "Empty command stack" -lostInSpace :: (Monad m) => m a -lostInSpace = error "The impossible has happened: unknown location in CLI" +findNext :: (Monad m) => Node m -> String -> StateM m ([Node m], String, String, String) +findNext = findNext' False -mkParser :: (MonadIO m) => (Bool -> String -> m ParseResult) -> Parser m -mkParser fun = - Parser $ \partial node@Node{..} input -> do - result <- labelParser partial node input - case result of - Done matched1 remaining1 -> do - r <- fun partial remaining1 - return $ case r of - Done matched2 remaining2 -> - Done (matched1 ++ ' ':matched2) remaining2 - o -> - o - x -> - return x +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 [] diff --git a/structured-cli.cabal b/structured-cli.cabal --- a/structured-cli.cabal +++ b/structured-cli.cabal @@ -1,5 +1,5 @@ name: structured-cli -version: 0.9.4.1 +version: 2.0.0.0 synopsis: Application library for building interactive console CLIs description: 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. homepage: https://gitlab.com/codemonkeylabs/structured-cli#readme @@ -22,7 +22,7 @@ , mtl , split , transformers - ghc-options: -Wall + ghc-options: -Wall -fno-warn-orphans default-language: Haskell2010 executable some-cli