structured-cli 0.9.4.1 → 2.0.0.0

raw patch · 3 files changed

+513/−369 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• example/Main.hs +28/−32
• src/System/Console/StructuredCLI.hs +483/−335
• structured-cli.cabal +2/−2

@@ -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 "<number of bars>") parseBars Nothing >+ do+bar = param "bar" "<number of bars>" 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 "<number of times to bar>"+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" }

@@ -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 <https://github.com/erickg/structured-cli/blob/master/example/Main.hs example/Main.hs> and modify it to suit your needs.-                                     Action,+-- A good way to get you started is to grab the example code available under <http://gitlab.com/codemonkeylabs/structured-cli/blob/master/example/Main.hs example/Main.hs> 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 <ctrl-C> 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 []

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