{-# LANGUAGE ImplicitParams, RecordWildCards, TupleSections #-}
module System.Console.StructuredCLI (
Action,
Commands,
CommandsT(..),
Parser,
ParseResult(..),
Settings(..),
State(..),
(>+),
command,
command',
exit,
mkParser,
outputStrLn,
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.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.Char (isSpace)
import Data.Default (Default, def)
import Data.IORef (IORef, readIORef)
import Data.List (filter, isPrefixOf, intercalate, span, sort)
import Data.Maybe (isJust, fromJust)
import Data.Monoid ((<>))
import Data.Typeable (Typeable)
import System.Console.Haskeline (Completion,
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,
disable :: Maybe (IORef Bool),
branches :: [Node m],
parser :: Parser m,
action :: Maybe (Action m) }
data Settings = Settings { history :: Maybe FilePath,
banner :: String,
prompt :: String,
batch :: Bool }
data CLIException = Exit deriving (Show, Typeable)
instance Exception CLIException
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)
| Options String [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 "" " > " False
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 Nothing [] 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 Nothing [] parser action
command' :: (MonadIO m)
=> String
-> Maybe String
-> Maybe (IORef Bool)
-> Maybe (Action m)
-> CommandsT m ()
command' name hint disable action =
CommandsT . return . ((),) . pure $ Node name hint disable [] def action
param' :: (Monad m)
=> String
-> Maybe String
-> Maybe (IORef Bool)
-> Parser m
-> Maybe (Action m)
-> CommandsT m ()
param' name hint disable parser action =
CommandsT . return . ((),) . pure $ Node name hint disable [] parser action
(>+) :: (Monad m) => CommandsT m () -> CommandsT m () -> CommandsT m ()
node >+ descendents = do
node' <- lift $ execCommandsT node
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
liftIO $ putStrLn "Nowhere else to go. Type <ctrl-C> anytime to exit"
return 0
_ ->
return 1
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
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
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,
labels = labels0 }
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
toPop = depth - depth'
void $ replicateM toPop popCommand
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 $ 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)
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
currentBranches :: (MonadIO m) => (CState m) [Node m]
currentBranches = getCurrentCommand >>= return . branches
currentBranches'' :: (MonadIO 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
disabled <- liftIO $ maybe (return False) readIORef disable
if disabled
then findNode input rest results
else do
result <- lift . lift .lift $ (runParser parser) False node input
case result of
Done matched remaining ->
return (node, matched, remaining)
Partial ->
error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label
_ ->
findNode input rest $ (Just result):results
findNode' :: (MonadIO m) => String -> [Node m] -> m (Maybe (Node m, String))
findNode' _ [] = return Nothing
findNode' input (node@Node{..}:rest) = do
disabled <- liftIO $ maybe (return False) readIORef disable
if disabled
then findNode' input rest
else do
result <- (runParser parser) False node input
case result of
Done _ remaining ->
return $ Just (node, remaining)
Options input' strs -> do
let nodes = fakeNode node <$> strs
findNode' input' nodes
Partial ->
error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label
_ ->
findNode' input rest
fakeNode :: (MonadIO m) => Node m -> String -> Node m
fakeNode node str = node { label = str, parser = Parser labelParser }
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 = sort $ fmap label options
let complete = completeWord Nothing " " $ \str ->
return $ map simpleCompletion $ filter (str `isPrefixOf`) keywords
complete input
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
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