structured-cli (empty) → 0.9.0.2
raw patch · 6 files changed
+605/−0 lines, 6 filesdep +basedep +data-defaultdep +haskelinesetup-changed
Dependencies added: base, data-default, haskeline, mtl, split, structured-cli, transformers
Files
- LICENSE +30/−0
- README.md +54/−0
- Setup.hs +2/−0
- example/Main.hs +73/−0
- src/System/Console/StructuredCLI.hs +405/−0
- structured-cli.cabal +41/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,54 @@+# structured-cli+#### Haskell library for building structured CLI applications++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.++* How to use this module:++The following code illustrates a simple but complete+CLI app:++```haskell+import Control.Monad.IO.Class (liftIO)+import System.Console.StructuredCLI++root :: Commands ()+root = do+ world >+ do+ hello+ bye+ exit $ Just "return to previous level"++world :: Commands ()+world = command "world" (Just "enter into world") Nothing++hello :: Commands ()+hello = command "hello" (Just "prints a greeting") $ Just $ do+ liftIO . putStrLn $ "Hello world!"+ return 0++bye :: Commands ()+bye = command "bye" (Just "say goodbye") $ Just $ do+ liftIO . putStrLn $ "Sayonara!"+ return 0++main :: IO ()+main = runCLI "Hello CLI" Nothing root+```++resulting example session:++```+Hello CLI > ?+- world: enter into world+Hello CLI > world+Hello CLI world >+bye exit hello+Hello CLI world > hello+Hello world!+Hello CLI world > exit+```++A good way to get you started is to grab the example code available under [example/Main.hs](https://github.com/erickg/structured-cli/blob/master/example/Main.hs) and modify it to suit your needs.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Main.hs view
@@ -0,0 +1,73 @@+{-# 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)++data State = State { bars :: Int,+ bazs :: Int }++type StateM = StateT State IO++root :: CommandsT StateM ()+root = do+ basic+ foo++basic :: CommandsT StateM ()+basic = do+ top $ Just "return to the top of the tree"+ exit $ Just "go back one level up"++foo :: CommandsT StateM ()+foo =+ command "foo" (Just "pity the foo") Nothing >+ do+ basic+ bar+ baz++bar :: CommandsT StateM ()+bar = param "bar" (Just "<number of bars>") parseBars Nothing >+ do+ basic+ frob++baz :: CommandsT StateM ()+baz = command "baz" (Just "do the baz thing") $ Just $ do+ n <- lift $ modify incBaz >> gets bazs+ liftIO . putStrLn $ "You have bazzed " ++ show n ++ " times"+ return 0+ where incBaz s@State{..} = s { bazs = bazs + 1 }++frob :: CommandsT StateM ()+frob = command "frob" (Just "frob this level") $ Just $ do+ n <- lift $ 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@State{..} -> s { bars = n }+ return $ Done x remaining++failure :: String -> ParseResult+failure name = Fail name $ Just "<number of times to bar>"++main :: IO ()+main = evalStateT (runCLI "some CLI" (Just settings) root) $ State 0 0+ where settings = def { banner = "Some CLI Application\nTab completion is your friend!",+ history = Just ".someCLI.history" }
+ src/System/Console/StructuredCLI.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE ImplicitParams, RecordWildCards, TupleSections #-}+-----------------------------------------------------------------------------+{- |+Module: System.Console.StructuredCLI+Description: Application library for building interactive console CLIs+Copyright: (c) Erick Gonzalez, 2017+License: BSD3+Maintainer: erick@codemonkeylabs.de++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.++-}+module System.Console.StructuredCLI (+-- * How to use this module:+-- |+-- The following code illustrates a simple but complete+-- CLI app:+--+-- @+-- import Control.Monad.IO.Class (liftIO)+-- import System.Console.StructuredCLI+--+-- root :: Commands ()+-- root = do+-- world >+ do+-- hello+-- bye+-- exit $ Just "return to previous level"+--+-- world :: Commands ()+-- world = command "world" (Just "enter into world") Nothing+--+-- hello :: Commands ()+-- hello = command "hello" (Just "prints a greeting") $ Just $ do+-- liftIO . putStrLn $ "Hello world!"+-- return 0+--+-- bye :: Commands ()+-- bye = command "bye" (Just "say goodbye") $ Just $ do+-- liftIO . putStrLn $ "Sayonara!"+-- return 0+--+-- main :: IO ()+-- main = runCLI "Hello CLI" Nothing root+-- @+--+-- resulting example session:+--+-- >>> Hello CLI > ?+-- - world: enter into world+-- >>> Hello CLI > world+-- >>> Hello CLI world >+-- bye exit hello+-- >>> Hello CLI world > hello+-- Hello world!+-- >>> Hello CLI world > exit+--+-- 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.+ Commands,+ CommandsT(..),+ Parser,+ ParseResult(..),+ Settings(..),+ (>+),+ command,+ exit,+ mkParser,+ outputStrLn,+ param,+ popCommand,+ pushCommand,+ runCLI,+ top) where++import Control.Applicative (liftA2)+import Control.Monad (foldM, replicateM, void, when)+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 Data.Char (isSpace)+import Data.Default (Default, def)+import Data.List (filter, isPrefixOf, intercalate, span, sort)+import Data.Monoid ((<>))+import System.Console.Haskeline (Completion,+ InputT,+ MonadException,+ completeWord,+ defaultSettings,+ getInputLine,+ outputStrLn,+ runInputT,+ setComplete,+ simpleCompletion)++import qualified System.Console.Haskeline as Haskeline++data State m = State { nodes :: [Node m],+ labels :: [String] }++type CState m = StateT (State m) m+type Action m = CState m Int++data Node m = Node { label :: String,+ hint :: Maybe String,+ branches :: [Node m],+ parser :: Parser m,+ action :: Maybe (Action m) }++data Settings = Settings { history :: Maybe FilePath,+ banner :: String,+ prompt :: String }++newtype CommandsT m a = CommandsT { runCommandsT :: m (a, [Node m]) }+type Commands = CommandsT IO++newtype Parser m = Parser { runParser :: (Bool -> Node m -> String -> m ParseResult) }++data ParseResult = Done String String+ | Fail String (Maybe String)+ | Partial+ deriving Show++instance (Functor f) => Functor (CommandsT f) where+ fmap f = CommandsT . fmap (\(a, w) -> (f a, w)) . runCommandsT++instance (Applicative a) => Applicative (CommandsT a) where+ pure = CommandsT . pure . (, mempty)+ x <*> y = CommandsT $ liftA2 f (runCommandsT x) (runCommandsT y)+ where f (a, v) (b, w) = (a b, v <> w)++instance (Monad m) => Monad (CommandsT m) where+ return = pure+ m >>= f = CommandsT $ do+ (a, v) <- runCommandsT m+ (b, w) <- runCommandsT $ f a+ return $ (b, v <> w)+ fail msg = CommandsT $ fail msg++instance MonadTrans CommandsT where+ lift m = CommandsT $ do+ a <- m+ return (a, mempty)++instance (MonadIO m) => Default (Parser m) where+ def = Parser labelParser++instance Default Settings where+ def = Settings Nothing "" " > "++nextWord :: String -> (String, String)+nextWord = span (not.isSpace) . dropWhile isSpace++trim :: String -> String+trim = reverse.dropWhile isSpace.reverse++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++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++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++(>+) :: (Monad m) => CommandsT m () -> CommandsT m () -> CommandsT m ()+node >+ descendents = do+ node' <- lift $ execCommandsT node+ case node' of+ [] ->+ error $ "Cannot branch off empty command"+ _:_:_ ->+ error $ "Cannot branch off more than one command"+ [predecessor] ->+ CommandsT $ do+ ns <- execCommandsT descendents+ return ((), [predecessor { branches = ns }])++execCommandsT :: (Monad m) => CommandsT m a -> m [Node m]+execCommandsT = fmap snd . runCommandsT++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++top :: (MonadIO m) => Maybe String -> CommandsT m ()+top hint = command "top" hint $ Just $ return (-maxBound)++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+ liftIO $ putStrLn banner+ return s+ let ?settings = maybe def id settings+ evalStateT loop $ stateFor root+ where stateFor root = State [Node name Nothing root noParse Nothing] [name]+ loop :: (?settings::Settings, MonadException m) => CState m ()+ loop = do+ settings <- getSettings $ history ?settings+ runInputT settings runLevel+ loop++runLevel :: (?settings::Settings, MonadException m) => InputT (CState m) ()+runLevel = do+ prompt <- lift getPrompt+ nodes0 <- lift $ gets nodes+ labels0 <- lift $ gets labels+ result <- runMaybeT $ do+ line <- MaybeT $ getInputLine prompt+ parse line+ case result of+ Nothing -> do+ 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+ Just _ -> do+ return ()++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++tryParse :: (MonadIO m) => String -> [Node m] -> m [Node m]+tryParse [] (x:_) = return [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)++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+ _ ->+ return $ node:acc++currentBranches :: (Monad m) => (CState m) [Node m]+currentBranches = getCurrentCommand >>= return . branches++currentBranches'' :: (Monad m,+ MonadTrans t,+ MonadTrans u,+ Monad (u (CState m))) =>+ t (u (CState m)) [Node m]+currentBranches'' = lift . lift $ currentBranches++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+ result <- lift . lift .lift $ (runParser parser) False node input+ case result of+ Done matched remaining ->+ return (node, matched, remaining)+ Fail _ _ ->+ findNode input rest $ (Just result):results+ Partial ->+ error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label++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)+ Partial ->+ error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label+ Fail _ _ ->+ findNode' input rest++pushCommand' :: (MonadTrans t, Monad m) => Node m -> String -> t (CState m) ()+pushCommand' n = lift . pushCommand n++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 }++popCommand :: (Monad m) => CState m ()+popCommand = do+ (_:cs) <- gets nodes+ (_:ls) <- gets labels+ modify $ \state -> state { nodes = cs, labels = ls }++getSettings :: (MonadIO m) => Maybe FilePath -> CState m (Haskeline.Settings (CState m))+getSettings path =+ return $ setComplete explorer defaultSettings { Haskeline.historyFile = path }++explorer :: (MonadIO m) => (String, String) -> CState m (String, [Completion])+explorer input@(left, _) = do+ nodes <- gets nodes+ options <- lift $ getPossibilities left nodes+ let keywords = getLabels options+ complete = completeWord Nothing " " $ \str ->+ return $ map simpleCompletion $ filter (str `isPrefixOf`) keywords+ r <- complete input+ return r+ where+ getLabels = sort . fmap label++getPossibilities :: (MonadIO m) => String -> [Node m] -> m [Node m]+getPossibilities "" = return . branches . head+getPossibilities input = tryParse $ reverse input++getCurrentCommand :: (Monad m) => CState m (Node m)+getCurrentCommand = do+ ns <- gets nodes+ case ns of+ [] ->+ lostInSpace+ node:_ ->+ return node++getPrompt :: (?settings::Settings, Monad m) => CState m String+getPrompt = buildPrompt <$> gets labels+ where buildPrompt ns = (intercalate " " . reverse $ ns) ++ prompt ?settings++lostInSpace :: (Monad m) => m a+lostInSpace = error "The impossible has happened: unknown location in CLI"++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
+ structured-cli.cabal view
@@ -0,0 +1,41 @@+name: structured-cli+version: 0.9.0.2+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://github.com/erickg/structured-cli#readme+license: BSD3+license-file: LICENSE+author: Erick Gonzalez+maintainer: erick@codemonkeylabs.de+copyright: 2017 Erick Gonzalez+category: Console+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: System.Console.StructuredCLI+ build-depends: base >= 4.7 && < 5+ , data-default+ , haskeline+ , mtl+ , split+ , transformers+ ghc-options: -Wall+ default-language: Haskell2010++executable some-cli+ hs-source-dirs: example+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -Wall+ build-depends: base+ , data-default+ , mtl+ , split+ , structured-cli+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/erickg/structured-cli