structured-cli 2.0.0.1 → 2.2.0.0
raw patch · 2 files changed
+129/−90 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- System.Console.StructuredCLI: [getCompletions] :: ParseResult -> [String]
+ System.Console.StructuredCLI: [getPartialHints] :: ParseResult -> [(String, String)]
+ System.Console.StructuredCLI: custom :: (Monad m) => String -> String -> Parser m -> m Bool -> Handler m -> CommandsT m ()
+ System.Console.StructuredCLI: data Node m
+ System.Console.StructuredCLI: isCompleted :: (Monad m) => SearchResult m -> Bool
+ System.Console.StructuredCLI: isIncomplete :: (Monad m) => SearchResult m -> Bool
+ System.Console.StructuredCLI: isNoResult :: (Monad m) => SearchResult m -> Bool
+ System.Console.StructuredCLI: labelParser :: (Monad m) => Node m -> String -> m ParseResult
- System.Console.StructuredCLI: Partial :: [String] -> String -> ParseResult
+ System.Console.StructuredCLI: Partial :: [(String, String)] -> String -> ParseResult
Files
- src/System/Console/StructuredCLI.hs +121/−89
- structured-cli.cabal +8/−1
src/System/Console/StructuredCLI.hs view
@@ -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
structured-cli.cabal view
@@ -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