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 @@ -67,10 +67,12 @@ State(..), (>+), command, + command', exit, mkParser, outputStrLn, param, + param', popCommand, pushCommand, runCLI, @@ -78,7 +80,7 @@ import Control.Applicative (liftA2) import Control.Exception (Exception, throw) -import Control.Monad (foldM, replicateM, void, when) +import Control.Monad (filterM, foldM, replicateM, void, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) @@ -89,7 +91,9 @@ -- string) 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.Monoid ((<>)) import Data.Typeable (Typeable) import System.Console.Haskeline (Completion, @@ -113,6 +117,7 @@ data Node m = Node { label :: String, hint :: Maybe String, + disable :: Maybe (IORef Bool), branches :: [Node m], parser :: Parser m, action :: Maybe (Action m) } @@ -189,13 +194,42 @@ noParse :: (Monad m) => Parser m noParse = Parser . const . const . const . return $ Fail "" Nothing -command :: (MonadIO m) => String -> Maybe String -> Maybe (Action m) -> CommandsT m () -command name hint action = CommandsT . return . ((),) . pure $ Node name hint [] def action +command :: (MonadIO m) + => String + -> Maybe String + -> Maybe (Action m) + -> CommandsT m () +command name hint action = + CommandsT . return . ((),) . pure $ Node name hint Nothing [] def action -param :: (Monad m) => String -> Maybe String -> Parser m -> Maybe (Action m) -> CommandsT m () +param :: (Monad m) + => String + -> Maybe String + -> Parser m + -> Maybe (Action m) + -> CommandsT m () param name hint parser action = - CommandsT . return . ((),) . pure $ Node name hint [] parser action + CommandsT . return . ((),) . pure $ Node name hint Nothing [] parser action +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 + +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 + (>+) :: (Monad m) => CommandsT m () -> CommandsT m () -> CommandsT m () node >+ descendents = do node' <- lift $ execCommandsT node @@ -238,7 +272,7 @@ return s let ?settings = maybe def id settings evalStateT loop $ stateFor root - where stateFor root = State [Node name Nothing root noParse Nothing] [name] + 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 @@ -259,7 +293,7 @@ throw Exit else lift $ modify $ \state -> state { nodes = nodes0, -- parse failed or no action - labels = labels0 } -- restore nodes to previous state + labels = labels0 } -- restore nodes to previous state Just _ -> do Node{..} <- lift getCurrentCommand case action of @@ -298,15 +332,19 @@ filterNodes :: (MonadIO m) => String -> [Node m] -> m [Node m] filterNodes input = foldM filterNodes' [] where filterNodes' acc node@Node{..} = 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 + 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 currentBranches :: (MonadIO m) => (CState m) [Node m] currentBranches = getCurrentCommand >>= return . branches @@ -334,29 +372,37 @@ matching kw (Just (Fail name _)) = kw `isPrefixOf` name matching _ _ = False findNode input (node@Node{..}:rest) results = 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 + 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 findNode' :: (MonadIO m) => String -> [Node m] -> m (Maybe (Node m, String)) findNode' _ [] = return Nothing findNode' input (node@Node{..}:rest) = 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 + 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 fakeNode :: (MonadIO m) => Node m -> String -> Node m fakeNode node str = node { label = str, parser = Parser labelParser } @@ -390,7 +436,12 @@ complete input getPossibilities :: (MonadIO m) => String -> [Node m] -> m [Node m] -getPossibilities "" = return . branches . head +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 getCurrentCommand :: (Monad m) => CState m (Node m) 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.0 +version: 0.9.4.1 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