diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 "") 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 "" + +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" } diff --git a/src/System/Console/StructuredCLI.hs b/src/System/Console/StructuredCLI.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/StructuredCLI.hs @@ -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 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 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 diff --git a/structured-cli.cabal b/structured-cli.cabal new file mode 100644 --- /dev/null +++ b/structured-cli.cabal @@ -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