{-# LANGUAGE ImplicitParams,
FlexibleContexts,
FlexibleInstances,
RecordWildCards,
TupleSections,
TypeSynonymInstances #-}
module System.Console.StructuredCLI (
Action(..),
CLIException(..),
Commands,
CommandsT,
Handler,
Parser,
ParseResult(..),
Settings(..),
Validator,
(>+),
command,
command',
exit,
newLevel,
noAction,
param,
param',
runCLI,
top) where
import Control.Applicative (liftA2)
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, get, gets, modify, put)
import Data.Char (isSpace)
import Data.Default (Default, def)
import Data.List (intercalate, isPrefixOf, sort, span)
import Data.Monoid ((<>))
import System.Console.Haskeline (MonadException)
import qualified System.Console.Haskeline as HL
data State m = State { stack :: [ Level m ] }
type Level m = ( String, Node m )
type StateM m = StateT (State m) m
type Handler m = String -> m Action
data Action
= NewLevel
| NoAction
| LevelUp Int
| ToRoot
deriving (Show)
data Node m = Node { getLabel :: String,
getHint :: String,
getBranches :: [Node m],
runParser :: Parser m,
isEnabled :: m Bool,
handle :: Handler m }
type Parser m = Node m -> String -> m ParseResult
type Validator m = String -> m (Maybe String)
type ExceptionHandler m = CLIException -> m (Either CLIException ())
data ParseResult =
Done {
getOutput :: String,
getDoneMatched :: String,
getDoneRemaining :: String }
| Partial {
getCompletions :: [String],
getPartialRemaining :: String }
| Fail {
getFailMessage :: String,
getFailRemaining :: String }
| NoMatch
deriving Show
data Settings m
= Settings {
getHistory :: Maybe FilePath,
getBanner :: String,
getPrompt :: String,
isBatch :: Bool,
handleException :: ExceptionHandler m }
data CLIException = Exit
| InternalError String
| SyntaxError String
| UndecisiveInput String [String]
| HelpRequested [(String, String)]
| InvalidOperation String
deriving Show
newtype CommandsT m a = CommandsT { runCommandsT :: m (a, [Node m]) }
type Commands = CommandsT IO
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 (Settings m) where
def = Settings Nothing "" " > " False defExceptionHandler
instance (Monad m) => Default (Parser m) where
def = labelParser
instance (Monad m) => Default (Validator m) where
def = return . pure . id
type ParserT m = ExceptT CLIException (HL.InputT (StateM m))
liftStateM :: (Monad m) => StateM m a -> ParserT m a
liftStateM = lift . lift
liftInputT :: (Monad m) => HL.InputT (StateM m) a -> ParserT m a
liftInputT = lift
liftUserM :: (Monad m) => m a -> ParserT m a
liftUserM = lift . lift . lift
execCommandsT :: (Monad m) => CommandsT m a -> m [Node m]
execCommandsT = fmap snd . runCommandsT
(>+) :: (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 { getBranches = ns }])
command :: (Monad m) => String
-> String
-> m Action
-> CommandsT m ()
command label hint action = do
command' label hint (return True) action
command' :: (Monad m) => String
-> String
-> m Bool
-> m Action
-> 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])
param :: (Monad m) => String
-> String
-> Validator m
-> Handler m
-> CommandsT m ()
param label hint validator handler =
param' label hint validator (return True) handler
param' :: (Monad m) => String
-> String
-> Validator m
-> m Bool
-> Handler m
-> 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])
top :: (Monad m) => m Action
top = return ToRoot
exit :: (Monad m) => m Action
exit = return $ LevelUp 1
newLevel :: (Monad m) => m Action
newLevel = return NewLevel
noAction :: (Monad m) => m Action
noAction = return NoAction
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
infixr 9 -.-
(-.-) :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
(-.-) = (.).(.)
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
nextWord :: String -> (String, String)
nextWord = span (not.isSpace) . dropWhile isSpace
hLineSettingsFrom :: (MonadIO m) => Settings m -> HL.Settings (StateM m)
hLineSettingsFrom Settings{..} =
HL.setComplete explorer HL.defaultSettings { HL.historyFile = getHistory }
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
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
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 ()
where buildPrompt ns = (intercalate " " . reverse $ ns) ++ getPrompt ?settings
withLabels = getStack >>= return . fmap fst
restore stack = liftStateM . modify $ \s -> s { stack = stack }
getStack :: (Monad m) => ParserT m [Level m]
getStack = liftStateM $ gets stack
process :: (Monad m) => String -> MaybeT (ParserT m) ()
process input = lift $ do
stack0 <- getStack
node <- getCurrentNode
action <- process' input node NewLevel
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
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 }
[] ->
throwError . InvalidOperation $ "Invalid attempt to pop element from empty command stack"
getCurrentNode :: (Monad m) => ParserT m (Node m)
getCurrentNode = do
stack <- liftStateM $ gets stack
case stack of
((_, node):_) -> return node
[] -> throwError . InternalError $ "Empty command stack"
findNext :: (Monad m) => Node m -> String -> StateM m ([Node m], String, String, String)
findNext = findNext' False
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
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 [" "]
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 []