structured-cli 0.9.4.0 → 0.9.4.1

raw patch · 2 files changed

+88/−37 lines, 2 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• src/System/Console/StructuredCLI.hs +87/−36
• structured-cli.cabal +1/−1

@@ -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)

@@ -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