{-# LANGUAGE CPP,
ImplicitParams,
FlexibleContexts,
FlexibleInstances,
RecordWildCards,
TupleSections,
TypeSynonymInstances #-}
module System.Console.StructuredCLI (
Action(..),
CLIException(..),
Commands,
CommandsT,
Handler,
Node,
Parser,
ParseResult(..),
Settings(..),
Validator,
(>+),
command,
command',
custom,
exit,
isCompleted,
isIncomplete,
isNoResult,
labelParser,
newLevel,
noAction,
param,
param',
runCLI,
top) where
import Control.Applicative (liftA2)
import Control.Monad (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
#ifdef __DEBUG__
import Debug.Trace
debugM :: (Applicative f) => String -> f ()
debugM = traceM
#else
debugM :: (Applicative f) => String -> f ()
debugM _ = pure ()
#endif
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 {
getPartialHints :: [(String, 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
data SearchResult m = Completed { completedNode :: Node m,
completedOutput :: String,
completedMatched :: String,
completedRemaining :: String }
| Incomplete { incompleteNode :: Node m,
incompleteHints :: [(String, String)] }
| Failed { failedNode :: Node m,
failedMsg :: String,
failedRemaining :: String }
| NoResult
isCompleted :: (Monad m) => SearchResult m -> Bool
isCompleted Completed{..} = True
isCompleted _ = False
isIncomplete :: (Monad m) => SearchResult m -> Bool
isIncomplete Incomplete{..} = True
isIncomplete _ = False
isNoResult :: (Monad m) => SearchResult m -> Bool
isNoResult NoResult = True
isNoResult _ = False
(>+) :: (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
custom label hint labelParser enable $ const action
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
custom label hint parser enable handler
where parser = paramParser hint validator
custom :: (Monad m) => String
-> String
-> Parser m
-> m Bool
-> Handler m
-> CommandsT m ()
custom label hint parser enable handler = do
let node = Node { getLabel = label,
getHint = hint,
getBranches = [],
runParser = parser,
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
("?", remaining) ->
return $ Fail getHint remaining
(word, remaining) | word == getLabel ->
return $ Done "" word remaining
(word, remaining) | word `isPrefixOf` getLabel ->
return $ Partial [(getLabel, getHint)] 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 _ = \_ input ->
return $ Partial [] input
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
debugM $ "processing " ++ show input ++ " on " ++ getLabel currentNode
result <- liftStateM $ findNext currentNode input
case result of
[Completed{ completedNode=node@Node{..}, ..}] -> do
push completedMatched node
action <- liftUserM $ handle completedOutput
process' completedRemaining node action
_ ->
if checkForHelp . dropWhile isSpace $ reverse input then do
let hints = foldl getHelp [] result
debugM $ "help requested: " ++ show hints
throwError . HelpRequested $ hints
else
throwError . SyntaxError $ input
where checkForHelp ('?':_) = True
checkForHelp _ = False
getHelp acc Failed{..} = (getLabel failedNode, failedMsg):acc
getHelp acc Incomplete{..} = incompleteHints ++ acc
getHelp acc Completed{..} = help completedNode : acc
getHelp acc _ = acc
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 [SearchResult m]
findNext root input = do
filter (not . isNoResult) <$> mapM matching branches
where matching node@Node{..} = do
enabled <- lift isEnabled
if enabled then do
result <- lift $ runParser node input
debugM $ "ran " ++ getLabel ++ " parser on " ++ show input ++ ": " ++ show result
case result of
Done output matched rest ->
return Completed { completedNode = node,
completedOutput = output,
completedMatched = matched,
completedRemaining = rest }
Fail msg rest ->
return Failed { failedNode = node,
failedMsg = msg,
failedRemaining = rest }
Partial hints _ ->
return Incomplete { incompleteNode = node,
incompleteHints = hints }
NoMatch ->
return NoResult
else
return NoResult
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
results <- findNext root input
case filter isCompleted results of
(_:_:_) ->
return []
Completed{..}:[] ->
getPossibilities completedNode completedRemaining
_ ->
return $ fst <$> foldl getPossibilities' [] results
where getPossibilities' acc Incomplete{..} = filter notEmpty incompleteHints ++ acc
getPossibilities' acc _ = acc
notEmpty ("", _) = False
notEmpty (_, _) = True