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,4 +1,5 @@ -{-# LANGUAGE ImplicitParams, +{-# LANGUAGE CPP, + ImplicitParams, FlexibleContexts, FlexibleInstances, RecordWildCards, @@ -79,6 +80,7 @@ Commands, CommandsT, Handler, + Node, Parser, ParseResult(..), Settings(..), @@ -86,7 +88,12 @@ (>+), command, command', + custom, exit, + isCompleted, + isIncomplete, + isNoResult, + labelParser, newLevel, noAction, param, @@ -95,7 +102,7 @@ top) where import Control.Applicative (liftA2) -import Control.Monad (foldM, mapM, replicateM_, void, when) +import Control.Monad (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) @@ -109,6 +116,15 @@ 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 ) @@ -130,6 +146,9 @@ | 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 = Node { getLabel :: String, getHint :: String, getBranches :: [Node m], @@ -157,8 +176,8 @@ -- | Remaining input data getDoneRemaining :: String } | Partial { - -- | List of possible completions after given input for this command - getCompletions :: [String], + -- | List of possible completions along with a corresponding help string + getPartialHints :: [(String, String)], -- | Remaining input data getPartialRemaining :: String } | Fail { @@ -264,6 +283,29 @@ execCommandsT :: (Monad m) => CommandsT m a -> m [Node m] execCommandsT = fmap snd . runCommandsT +data SearchResult m = Completed { completedNode :: Node m, + completedOutput :: String, + 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 + -- | 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: -- @ @@ -309,13 +351,7 @@ -> 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]) + 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 string @@ -323,7 +359,7 @@ 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@) + -> Handler m -- ^ Handling action. Takes the validator output as argument -> CommandsT m () param label hint validator handler = param' label hint validator (return True) handler @@ -335,13 +371,24 @@ -> 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@) + -> Handler m -- ^ 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 -- ^ Custom parser (runs in the "user" monad) + -> m Bool -- ^ Enable action in the "user" monad + -> Handler m -- ^ 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 = paramParser hint validator, + runParser = parser, isEnabled = enable, handle = handler } CommandsT . return $ ((), [node]) @@ -362,13 +409,17 @@ 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 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] remaining + return $ Partial [(getLabel, getHint)] remaining (_, _) -> return $ NoMatch @@ -419,8 +470,8 @@ liftStateM $ put state throwError e processInput - dummyParser' _ t = return . (flip Partial) t . fmap getLabel - dummyParser r s t = dummyParser' s t r + dummyParser _ = \_ input -> + return $ Partial [] input state0 root = State [(name, mkNode root)] mkNode root = Node { getLabel = name, @@ -504,22 +555,26 @@ 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 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 () + [Completed{ completedNode=node@Node{..}, ..}] -> do + push completedMatched node + action <- liftUserM $ handle completedOutput + 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 + 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) @@ -545,43 +600,32 @@ ((_, 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 +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 - 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 + if enabled then do + result <- lift $ runParser node input + debugM $ "ran " ++ getLabel ++ " parser on " ++ show input ++ ": " ++ show result + case result of + Done output matched rest -> + return Completed { completedNode = node, + completedOutput = 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 acc - matching acc _ = return acc -- short circuit out of the fold if output is not empty - branches = getBranches root + return NoResult + branches = getBranches root explorer :: (Monad m) => HL.CompletionFunc (StateM m) explorer input@(tfel, _) = do @@ -598,27 +642,15 @@ 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 - ([], _, _, _) -> + results <- findNext root input + case filter isCompleted results of + (_:_:_) -> 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 [] + Completed{..}:[] -> + getPossibilities completedNode completedRemaining + _ -> + return $ fst <$> foldl getPossibilities' [] results + where getPossibilities' acc Incomplete{..} = filter notEmpty incompleteHints ++ acc + getPossibilities' acc _ = acc + notEmpty ("", _) = False + notEmpty (_, _) = True 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: 2.0.0.1 +version: 2.2.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 @@ -13,6 +13,10 @@ extra-source-files: README.md cabal-version: >=1.10 +flag debug + description: Enable debug messages + default: False + library hs-source-dirs: src exposed-modules: System.Console.StructuredCLI @@ -24,6 +28,9 @@ , transformers ghc-options: -Wall -fno-warn-orphans default-language: Haskell2010 + if flag(debug) { + cpp-options: -D__DEBUG__ + } executable some-cli hs-source-dirs: example