structured-cli-0.9.0.3: src/System/Console/StructuredCLI.hs
{-# 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) => MonadIO (CommandsT m) where
liftIO = lift . liftIO
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