{-# LANGUAGE CPP,
ImplicitParams,
ExistentialQuantification,
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,
isFailed,
labelParser,
newLevel,
noAction,
param,
param',
paramParser,
parseOneOf,
runCLI,
top) where
import Control.Applicative (liftA2)
import Control.Monad (replicateM_, void, when)
import Control.Monad.Catch (MonadMask)
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)
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 :: String -> f ()
debugM String
_ = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#endif
data State m = State { State m -> [Level m]
stack :: [ Level m ] }
type Level m = ( String, Node m )
type StateM m = StateT (State m) m
type Handler m a = a -> m Action
data Action
= NewLevel
| NoAction
| LevelUp Int
| ToRoot
deriving (Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show)
data Node m = forall a . Node {
Node m -> String
getLabel :: String,
Node m -> String
getHint :: String,
Node m -> [Node m]
getBranches :: [Node m],
()
runParser :: Parser m a,
Node m -> m Bool
isEnabled :: m Bool,
()
handle :: Handler m a }
type Parser m a = Node m -> String -> m (ParseResult a)
type Validator m a = String -> m (Maybe a)
type ExceptionHandler m = CLIException -> m (Either CLIException ())
data ParseResult a =
Done {
ParseResult a -> a
getOutput :: a,
ParseResult a -> String
getDoneMatched :: String,
ParseResult a -> String
getDoneRemaining :: String }
| Partial {
ParseResult a -> [(String, String)]
getPartialHints :: [(String, String)],
ParseResult a -> String
getPartialRemaining :: String }
| Fail {
ParseResult a -> String
getFailMessage :: String,
ParseResult a -> String
getFailRemaining :: String }
| NoMatch
deriving Int -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> String
(Int -> ParseResult a -> ShowS)
-> (ParseResult a -> String)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
forall a. Show a => Int -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseResult a] -> ShowS
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
show :: ParseResult a -> String
$cshow :: forall a. Show a => ParseResult a -> String
showsPrec :: Int -> ParseResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
Show
data Settings m
= Settings {
Settings m -> Maybe String
getHistory :: Maybe FilePath,
Settings m -> String
getBanner :: String,
Settings m -> m String
getPrompt :: m String,
Settings m -> Bool
isBatch :: Bool,
Settings m -> ExceptionHandler m
handleException :: ExceptionHandler m }
data CLIException = Exit
| InternalError String
| SyntaxError String String
| UndecisiveInput String [String]
| HelpRequested [(String, String)]
| InvalidOperation String
deriving Int -> CLIException -> ShowS
[CLIException] -> ShowS
CLIException -> String
(Int -> CLIException -> ShowS)
-> (CLIException -> String)
-> ([CLIException] -> ShowS)
-> Show CLIException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CLIException] -> ShowS
$cshowList :: [CLIException] -> ShowS
show :: CLIException -> String
$cshow :: CLIException -> String
showsPrec :: Int -> CLIException -> ShowS
$cshowsPrec :: Int -> CLIException -> ShowS
Show
newtype CommandsT m a = CommandsT { CommandsT m a -> m (a, [Node m])
runCommandsT :: m (a, [Node m]) }
type Commands = CommandsT IO
instance (Functor f) => Functor (CommandsT f) where
fmap :: (a -> b) -> CommandsT f a -> CommandsT f b
fmap a -> b
f = f (b, [Node f]) -> CommandsT f b
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (f (b, [Node f]) -> CommandsT f b)
-> (CommandsT f a -> f (b, [Node f]))
-> CommandsT f a
-> CommandsT f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, [Node f]) -> (b, [Node f]))
-> f (a, [Node f]) -> f (b, [Node f])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
a, [Node f]
w) -> (a -> b
f a
a, [Node f]
w)) (f (a, [Node f]) -> f (b, [Node f]))
-> (CommandsT f a -> f (a, [Node f]))
-> CommandsT f a
-> f (b, [Node f])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandsT f a -> f (a, [Node f])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT
instance (Applicative a) => Applicative (CommandsT a) where
pure :: a -> CommandsT a a
pure = a (a, [Node a]) -> CommandsT a a
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (a (a, [Node a]) -> CommandsT a a)
-> (a -> a (a, [Node a])) -> a -> CommandsT a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [Node a]) -> a (a, [Node a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, [Node a]) -> a (a, [Node a]))
-> (a -> (a, [Node a])) -> a -> a (a, [Node a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, [Node a]
forall a. Monoid a => a
mempty)
CommandsT a (a -> b)
x <*> :: CommandsT a (a -> b) -> CommandsT a a -> CommandsT a b
<*> CommandsT a a
y = a (b, [Node a]) -> CommandsT a b
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (a (b, [Node a]) -> CommandsT a b)
-> a (b, [Node a]) -> CommandsT a b
forall a b. (a -> b) -> a -> b
$ ((a -> b, [Node a]) -> (a, [Node a]) -> (b, [Node a]))
-> a (a -> b, [Node a]) -> a (a, [Node a]) -> a (b, [Node a])
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (a -> b, [Node a]) -> (a, [Node a]) -> (b, [Node a])
forall b t a. Semigroup b => (t -> a, b) -> (t, b) -> (a, b)
f (CommandsT a (a -> b) -> a (a -> b, [Node a])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT CommandsT a (a -> b)
x) (CommandsT a a -> a (a, [Node a])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT CommandsT a a
y)
where f :: (t -> a, b) -> (t, b) -> (a, b)
f (t -> a
a, b
v) (t
b, b
w) = (t -> a
a t
b, b
v b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
w)
instance (Monad m) => Monad (CommandsT m) where
return :: a -> CommandsT m a
return = a -> CommandsT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
CommandsT m a
m >>= :: CommandsT m a -> (a -> CommandsT m b) -> CommandsT m b
>>= a -> CommandsT m b
f = m (b, [Node m]) -> CommandsT m b
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (m (b, [Node m]) -> CommandsT m b)
-> m (b, [Node m]) -> CommandsT m b
forall a b. (a -> b) -> a -> b
$ do
(a
a, [Node m]
v) <- CommandsT m a -> m (a, [Node m])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT CommandsT m a
m
(b
b, [Node m]
w) <- CommandsT m b -> m (b, [Node m])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT (CommandsT m b -> m (b, [Node m]))
-> CommandsT m b -> m (b, [Node m])
forall a b. (a -> b) -> a -> b
$ a -> CommandsT m b
f a
a
(b, [Node m]) -> m (b, [Node m])
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, [Node m]) -> m (b, [Node m]))
-> (b, [Node m]) -> m (b, [Node m])
forall a b. (a -> b) -> a -> b
$ (b
b, [Node m]
v [Node m] -> [Node m] -> [Node m]
forall a. Semigroup a => a -> a -> a
<> [Node m]
w)
instance MonadTrans CommandsT where
lift :: m a -> CommandsT m a
lift m a
m = m (a, [Node m]) -> CommandsT m a
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (m (a, [Node m]) -> CommandsT m a)
-> m (a, [Node m]) -> CommandsT m a
forall a b. (a -> b) -> a -> b
$ do
a
a <- m a
m
(a, [Node m]) -> m (a, [Node m])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, [Node m]
forall a. Monoid a => a
mempty)
instance (MonadIO m) => MonadIO (CommandsT m) where
liftIO :: IO a -> CommandsT m a
liftIO = m a -> CommandsT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CommandsT m a) -> (IO a -> m a) -> IO a -> CommandsT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance (MonadIO m) => Default (Settings m) where
def :: Settings m
def = Maybe String
-> String -> m String -> Bool -> ExceptionHandler m -> Settings m
forall (m :: * -> *).
Maybe String
-> String -> m String -> Bool -> ExceptionHandler m -> Settings m
Settings Maybe String
forall a. Maybe a
Nothing String
"" (String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
" > ") Bool
False ExceptionHandler m
forall (m :: * -> *).
MonadIO m =>
CLIException -> m (Either CLIException ())
defExceptionHandler
instance (Monad m) => Default (Parser m String) where
def :: Parser m String
def = Parser m String
forall (m :: * -> *). Monad m => Parser m String
labelParser
instance (Monad m) => Default (Validator m String) where
def :: Validator m String
def = Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> (String -> Maybe String) -> Validator m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure
type ParserT m = ExceptT CLIException (HL.InputT (StateM m))
liftStateM :: (Monad m) => StateM m a -> ParserT m a
liftStateM :: StateM m a -> ParserT m a
liftStateM = InputT (StateM m) a -> ParserT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT (StateM m) a -> ParserT m a)
-> (StateM m a -> InputT (StateM m) a) -> StateM m a -> ParserT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateM m a -> InputT (StateM m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
liftInputT :: (Monad m) => HL.InputT (StateM m) a -> ParserT m a
liftInputT :: InputT (StateM m) a -> ParserT m a
liftInputT = InputT (StateM m) a -> ParserT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
liftUserM :: (Monad m) => m a -> ParserT m a
liftUserM :: m a -> ParserT m a
liftUserM = InputT (StateT (State m) m) a -> ParserT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT (StateT (State m) m) a -> ParserT m a)
-> (m a -> InputT (StateT (State m) m) a) -> m a -> ParserT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (State m) m a -> InputT (StateT (State m) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (State m) m a -> InputT (StateT (State m) m) a)
-> (m a -> StateT (State m) m a)
-> m a
-> InputT (StateT (State m) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT (State m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
execCommandsT :: (Monad m) => CommandsT m a -> m [Node m]
execCommandsT :: CommandsT m a -> m [Node m]
execCommandsT = ((a, [Node m]) -> [Node m]) -> m (a, [Node m]) -> m [Node m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, [Node m]) -> [Node m]
forall a b. (a, b) -> b
snd (m (a, [Node m]) -> m [Node m])
-> (CommandsT m a -> m (a, [Node m]))
-> CommandsT m a
-> m [Node m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandsT m a -> m (a, [Node m])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT
data SearchResult m = Completed { SearchResult m -> Node m
completedNode :: Node m,
SearchResult m -> m Action
completedAction :: m Action,
SearchResult m -> String
completedMatched :: String,
SearchResult m -> String
completedRemaining :: String }
| Incomplete { SearchResult m -> Node m
incompleteNode :: Node m,
SearchResult m -> [(String, String)]
incompleteHints :: [(String, String)] }
| Failed { SearchResult m -> Node m
failedNode :: Node m,
SearchResult m -> String
failedMsg :: String,
SearchResult m -> String
failedRemaining :: String }
| NoResult
isCompleted :: (Monad m) => SearchResult m -> Bool
isCompleted :: SearchResult m -> Bool
isCompleted Completed{m Action
String
Node m
completedRemaining :: String
completedMatched :: String
completedAction :: m Action
completedNode :: Node m
completedRemaining :: forall (m :: * -> *). SearchResult m -> String
completedMatched :: forall (m :: * -> *). SearchResult m -> String
completedAction :: forall (m :: * -> *). SearchResult m -> m Action
completedNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = Bool
True
isCompleted SearchResult m
_ = Bool
False
isIncomplete :: (Monad m) => SearchResult m -> Bool
isIncomplete :: SearchResult m -> Bool
isIncomplete Incomplete{[(String, String)]
Node m
incompleteHints :: [(String, String)]
incompleteNode :: Node m
incompleteHints :: forall (m :: * -> *). SearchResult m -> [(String, String)]
incompleteNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = Bool
True
isIncomplete SearchResult m
_ = Bool
False
isNoResult :: (Monad m) => SearchResult m -> Bool
isNoResult :: SearchResult m -> Bool
isNoResult SearchResult m
NoResult = Bool
True
isNoResult SearchResult m
_ = Bool
False
isFailed :: (Monad m) => SearchResult m -> Bool
isFailed :: SearchResult m -> Bool
isFailed Failed{String
Node m
failedRemaining :: String
failedMsg :: String
failedNode :: Node m
failedRemaining :: forall (m :: * -> *). SearchResult m -> String
failedMsg :: forall (m :: * -> *). SearchResult m -> String
failedNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = Bool
True
isFailed SearchResult m
_ = Bool
False
(>+) :: (Monad m) => CommandsT m () -> CommandsT m () -> CommandsT m ()
CommandsT m ()
node >+ :: CommandsT m () -> CommandsT m () -> CommandsT m ()
>+ CommandsT m ()
descendents = do
[Node m]
node' <- m [Node m] -> CommandsT m [Node m]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [Node m] -> CommandsT m [Node m])
-> m [Node m] -> CommandsT m [Node m]
forall a b. (a -> b) -> a -> b
$ CommandsT m () -> m [Node m]
forall (m :: * -> *) a. Monad m => CommandsT m a -> m [Node m]
execCommandsT CommandsT m ()
node
case [Node m]
node' of
[] ->
String -> CommandsT m ()
forall a. HasCallStack => String -> a
error (String -> CommandsT m ()) -> String -> CommandsT m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot branch off empty command"
Node m
_:Node m
_:[Node m]
_ ->
String -> CommandsT m ()
forall a. HasCallStack => String -> a
error (String -> CommandsT m ()) -> String -> CommandsT m ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot branch off more than one command"
[Node m
predecessor] ->
m ((), [Node m]) -> CommandsT m ()
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (m ((), [Node m]) -> CommandsT m ())
-> m ((), [Node m]) -> CommandsT m ()
forall a b. (a -> b) -> a -> b
$ do
[Node m]
ns <- CommandsT m () -> m [Node m]
forall (m :: * -> *) a. Monad m => CommandsT m a -> m [Node m]
execCommandsT CommandsT m ()
descendents
((), [Node m]) -> m ((), [Node m])
forall (m :: * -> *) a. Monad m => a -> m a
return ((), [Node m
predecessor { getBranches :: [Node m]
getBranches = [Node m]
ns }])
command :: (Monad m) => String
-> String
-> m Action
-> CommandsT m ()
command :: String -> String -> m Action -> CommandsT m ()
command String
label String
hint m Action
action = do
String -> String -> m Bool -> m Action -> CommandsT m ()
forall (m :: * -> *).
Monad m =>
String -> String -> m Bool -> m Action -> CommandsT m ()
command' String
label String
hint (Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) m Action
action
command' :: (Monad m) => String
-> String
-> m Bool
-> m Action
-> CommandsT m ()
command' :: String -> String -> m Bool -> m Action -> CommandsT m ()
command' String
label String
hint m Bool
enable m Action
action = do
String
-> String
-> Parser m String
-> m Bool
-> Handler m String
-> CommandsT m ()
forall (m :: * -> *) a.
Monad m =>
String
-> String -> Parser m a -> m Bool -> Handler m a -> CommandsT m ()
custom String
label String
hint Parser m String
forall (m :: * -> *). Monad m => Parser m String
labelParser m Bool
enable (Handler m String -> CommandsT m ())
-> Handler m String -> CommandsT m ()
forall a b. (a -> b) -> a -> b
$ m Action -> Handler m String
forall a b. a -> b -> a
const m Action
action
param :: (Monad m) => String
-> String
-> Validator m a
-> Handler m a
-> CommandsT m ()
param :: String -> String -> Validator m a -> Handler m a -> CommandsT m ()
param String
label String
hint Validator m a
validator Handler m a
handler =
String
-> String
-> Validator m a
-> m Bool
-> Handler m a
-> CommandsT m ()
forall (m :: * -> *) a.
Monad m =>
String
-> String
-> Validator m a
-> m Bool
-> Handler m a
-> CommandsT m ()
param' String
label String
hint Validator m a
validator (Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Handler m a
handler
param' :: (Monad m) => String
-> String
-> Validator m a
-> m Bool
-> Handler m a
-> CommandsT m ()
param' :: String
-> String
-> Validator m a
-> m Bool
-> Handler m a
-> CommandsT m ()
param' String
label String
hint Validator m a
validator m Bool
enable Handler m a
handler = do
String
-> String -> Parser m a -> m Bool -> Handler m a -> CommandsT m ()
forall (m :: * -> *) a.
Monad m =>
String
-> String -> Parser m a -> m Bool -> Handler m a -> CommandsT m ()
custom String
label String
hint Parser m a
parser m Bool
enable Handler m a
handler
where parser :: Parser m a
parser = String -> Validator m a -> Parser m a
forall (m :: * -> *) a.
Monad m =>
String
-> (String -> m (Maybe a)) -> Node m -> String -> m (ParseResult a)
paramParser String
hint Validator m a
validator
custom :: (Monad m) => String
-> String
-> Parser m a
-> m Bool
-> Handler m a
-> CommandsT m ()
custom :: String
-> String -> Parser m a -> m Bool -> Handler m a -> CommandsT m ()
custom String
label String
hint Parser m a
parser m Bool
enable Handler m a
handler = do
let node :: Node m
node = Node :: forall (m :: * -> *) a.
String
-> String
-> [Node m]
-> Parser m a
-> m Bool
-> Handler m a
-> Node m
Node { getLabel :: String
getLabel = String
label,
getHint :: String
getHint = String
hint,
getBranches :: [Node m]
getBranches = [],
runParser :: Parser m a
runParser = Parser m a
parser,
isEnabled :: m Bool
isEnabled = m Bool
enable,
handle :: Handler m a
handle = Handler m a
handler }
m ((), [Node m]) -> CommandsT m ()
forall (m :: * -> *) a. m (a, [Node m]) -> CommandsT m a
CommandsT (m ((), [Node m]) -> CommandsT m ())
-> (((), [Node m]) -> m ((), [Node m]))
-> ((), [Node m])
-> CommandsT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), [Node m]) -> m ((), [Node m])
forall (m :: * -> *) a. Monad m => a -> m a
return (((), [Node m]) -> CommandsT m ())
-> ((), [Node m]) -> CommandsT m ()
forall a b. (a -> b) -> a -> b
$ ((), [Node m
node])
top :: (Monad m) => m Action
top :: m Action
top = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
ToRoot
exit :: (Monad m) => m Action
exit :: m Action
exit = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return (Action -> m Action) -> Action -> m Action
forall a b. (a -> b) -> a -> b
$ Int -> Action
LevelUp Int
1
newLevel :: (Monad m) => m Action
newLevel :: m Action
newLevel = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
NewLevel
noAction :: (Monad m) => m Action
noAction :: m Action
noAction = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
NoAction
labelParser :: (Monad m) => Node m -> String -> m (ParseResult String)
labelParser :: Node m -> String -> m (ParseResult String)
labelParser Node{m Bool
String
[Node m]
Handler m a
Parser m a
handle :: Handler m a
isEnabled :: m Bool
runParser :: Parser m a
getBranches :: [Node m]
getHint :: String
getLabel :: String
handle :: ()
isEnabled :: forall (m :: * -> *). Node m -> m Bool
runParser :: ()
getBranches :: forall (m :: * -> *). Node m -> [Node m]
getHint :: forall (m :: * -> *). Node m -> String
getLabel :: forall (m :: * -> *). Node m -> String
..} String
input = do
case String -> (String, String)
nextWord String
input of
(String
"?", String
remaining) ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseResult String
forall a. String -> String -> ParseResult a
Fail String
getHint String
remaining
(String
word, String
remaining) | String
word String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
getLabel ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> ParseResult String
forall a. a -> String -> String -> ParseResult a
Done String
"" String
word String
remaining
(String
word, String
remaining) | String
word String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
getLabel ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> ParseResult String
forall a. [(String, String)] -> String -> ParseResult a
Partial [(String
getLabel, String
getHint)] String
remaining
(String
_, String
_) ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ ParseResult String
forall a. ParseResult a
NoMatch
infixr 9 -.-
(-.-) :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
-.- :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
(-.-) = ((a1 -> b) -> a1 -> c) -> (a -> a1 -> b) -> a -> a1 -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)(((a1 -> b) -> a1 -> c) -> (a -> a1 -> b) -> a -> a1 -> c)
-> ((b -> c) -> (a1 -> b) -> a1 -> c)
-> (b -> c)
-> (a -> a1 -> b)
-> a
-> a1
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b -> c) -> (a1 -> b) -> a1 -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
parseOneOf :: (Monad m) => [String] -> String-> Node m -> String -> m (ParseResult String)
parseOneOf :: [String] -> String -> Node m -> String -> m (ParseResult String)
parseOneOf [String]
possibilities String
hint = m (ParseResult String) -> m (ParseResult String)
parseOneOf' (m (ParseResult String) -> m (ParseResult String))
-> (Node m -> String -> m (ParseResult String))
-> Node m
-> String
-> m (ParseResult String)
forall b c a a1. (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
-.- Node m -> String -> m (ParseResult String)
forall (m :: * -> *). Monad m => Parser m String
labelParser
where parseOneOf' :: m (ParseResult String) -> m (ParseResult String)
parseOneOf' = (ParseResult String -> m (ParseResult String))
-> m (ParseResult String) -> m (ParseResult String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) ParseResult String -> m (ParseResult String)
forall (m :: * -> *).
Monad m =>
ParseResult String -> m (ParseResult String)
parseOneOf''
parseOneOf'' :: (Monad m) => ParseResult String -> m (ParseResult String)
parseOneOf'' :: ParseResult String -> m (ParseResult String)
parseOneOf'' (Done String
_ String
_ String
rest) =
case String -> (String, String)
nextWord String
rest of
(String
"?", String
_) ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseResult String
forall a. String -> String -> ParseResult a
Fail String
hint String
rest
(String
"", String
remaining) ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> ParseResult String
forall a. [(String, String)] -> String -> ParseResult a
Partial ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
possibilities ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. a -> [a]
repeat String
"") String
remaining
(String
word, String
_) -> do
[ParseResult String]
results <- ((String, String) -> m (ParseResult String))
-> [(String, String)] -> m [ParseResult String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> (String, String) -> m (ParseResult String)
forall (m :: * -> *).
Monad m =>
String -> (String, String) -> m (ParseResult String)
parseOne String
word) ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
possibilities ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. a -> [a]
repeat String
"")
case (ParseResult String -> Bool)
-> [ParseResult String] -> [ParseResult String]
forall a. (a -> Bool) -> [a] -> [a]
filter ParseResult String -> Bool
forall a. ParseResult a -> Bool
isDone [ParseResult String]
results of
(Done String
_ String
matched String
remaining:[ParseResult String]
_) -> ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> ParseResult String
forall a. a -> String -> String -> ParseResult a
Done String
matched String
matched String
remaining
[ParseResult String]
_ ->
case (ParseResult String -> Bool)
-> [ParseResult String] -> [ParseResult String]
forall a. (a -> Bool) -> [a] -> [a]
filter ParseResult String -> Bool
forall a. ParseResult a -> Bool
isPartial [ParseResult String]
results of
[] ->
case [ParseResult String]
results of
(ParseResult String
result':[ParseResult String]
_) -> ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult String
result'
[ParseResult String]
_ -> ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult String
forall a. ParseResult a
NoMatch
[ParseResult String]
partials ->
ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ (ParseResult String -> ParseResult String -> ParseResult String)
-> ParseResult String -> [ParseResult String] -> ParseResult String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ParseResult String -> ParseResult String -> ParseResult String
forall a a a. ParseResult a -> ParseResult a -> ParseResult a
merge ([(String, String)] -> String -> ParseResult String
forall a. [(String, String)] -> String -> ParseResult a
Partial [] String
"") [ParseResult String]
partials
parseOneOf'' (Fail String
hint' String
rest) = ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseResult String
forall a. String -> String -> ParseResult a
Fail String
hint' String
rest
parseOneOf'' (Partial [(String, String)]
xs String
rest) = ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult String -> m (ParseResult String))
-> ParseResult String -> m (ParseResult String)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> ParseResult String
forall a. [(String, String)] -> String -> ParseResult a
Partial [(String, String)]
xs String
rest
parseOneOf'' ParseResult String
NoMatch = ParseResult String -> m (ParseResult String)
forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult String
forall a. ParseResult a
NoMatch
merge :: ParseResult a -> ParseResult a -> ParseResult a
merge (Partial [(String, String)]
ps String
_) (Partial [(String, String)]
ps' String
rest') = [(String, String)] -> String -> ParseResult a
forall a. [(String, String)] -> String -> ParseResult a
Partial ([(String, String)]
ps [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
ps') String
rest'
merge ParseResult a
_ ParseResult a
_ = String -> ParseResult a
forall a. HasCallStack => String -> a
error String
"Internal inconsistency merging partial results from parseOneOf"
isDone :: ParseResult a -> Bool
isDone (Done a
_ String
_ String
_) = Bool
True
isDone ParseResult a
_ = Bool
False
isPartial :: ParseResult a -> Bool
isPartial (Partial [(String, String)]
_ String
_) = Bool
True
isPartial ParseResult a
_ = Bool
False
parseOne :: String -> (String, String) -> m (ParseResult String)
parseOne String
input (String
str, String
hint') = Node m -> String -> m (ParseResult String)
forall (m :: * -> *). Monad m => Parser m String
labelParser Node :: forall (m :: * -> *) a.
String
-> String
-> [Node m]
-> Parser m a
-> m Bool
-> Handler m a
-> Node m
Node { getLabel :: String
getLabel = String
str,
getHint :: String
getHint = String
hint',
getBranches :: [Node m]
getBranches = [],
isEnabled :: m Bool
isEnabled = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
runParser :: Parser m Any
runParser = String -> Parser m Any
forall a. HasCallStack => String -> a
error String
"dummy parser",
handle :: Handler m Any
handle = m Action -> Handler m Any
forall a b. a -> b -> a
const (m Action -> Handler m Any) -> m Action -> Handler m Any
forall a b. (a -> b) -> a -> b
$ Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
NoAction
} String
input
paramParser :: Monad m => String -> (String -> m (Maybe a)) -> Node m -> String -> m (ParseResult a)
paramParser :: String
-> (String -> m (Maybe a)) -> Node m -> String -> m (ParseResult a)
paramParser String
hint String -> m (Maybe a)
validator = m (ParseResult String) -> m (ParseResult a)
forall a. m (ParseResult a) -> m (ParseResult a)
parseParam (m (ParseResult String) -> m (ParseResult a))
-> (Node m -> String -> m (ParseResult String))
-> Node m
-> String
-> m (ParseResult a)
forall b c a a1. (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
-.- Node m -> String -> m (ParseResult String)
forall (m :: * -> *). Monad m => Parser m String
labelParser
where parseParam :: m (ParseResult a) -> m (ParseResult a)
parseParam = (ParseResult a -> m (ParseResult a))
-> m (ParseResult a) -> m (ParseResult a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) ParseResult a -> m (ParseResult a)
forall a. ParseResult a -> m (ParseResult a)
parseParam'
parseParam' :: ParseResult a -> m (ParseResult a)
parseParam' (Done a
_ String
matched String
rest) =
case String -> (String, String)
nextWord String
rest of
(String
"?", String
_) ->
ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult a -> m (ParseResult a))
-> ParseResult a -> m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseResult a
forall a. String -> String -> ParseResult a
Fail String
hint String
rest
(String
"", String
remaining) ->
ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult a -> m (ParseResult a))
-> ParseResult a -> m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> ParseResult a
forall a. [(String, String)] -> String -> ParseResult a
Partial [(String
"", String
hint)] String
remaining
(String
word, String
remaining) -> do
Maybe a
v <- String -> m (Maybe a)
validator String
word
ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult a -> m (ParseResult a))
-> ParseResult a -> m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ ParseResult a -> (a -> ParseResult a) -> Maybe a -> ParseResult a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ParseResult a
forall a. String -> ParseResult a
badArg String
rest) (\a
x -> a -> String -> String -> ParseResult a
forall a. a -> String -> String -> ParseResult a
Done a
x (String
matched String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
word) String
remaining) Maybe a
v
parseParam' (Fail String
x String
y) =
ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult a -> m (ParseResult a))
-> ParseResult a -> m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ String -> String -> ParseResult a
forall a. String -> String -> ParseResult a
Fail String
x String
y
parseParam' (Partial [(String, String)]
x String
y) =
ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult a -> m (ParseResult a))
-> ParseResult a -> m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> ParseResult a
forall a. [(String, String)] -> String -> ParseResult a
Partial [(String, String)]
x String
y
parseParam' ParseResult a
NoMatch = ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult a
forall a. ParseResult a
NoMatch
badArg :: String -> ParseResult a
badArg = String -> String -> ParseResult a
forall a. String -> String -> ParseResult a
Fail String
hint
nextWord :: String -> (String, String)
nextWord :: String -> (String, String)
nextWord = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) (String -> (String, String)) -> ShowS -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
hLineSettingsFrom :: (MonadIO m) => Settings m -> HL.Settings (StateM m)
hLineSettingsFrom :: Settings m -> Settings (StateM m)
hLineSettingsFrom Settings{m String
Bool
String
Maybe String
ExceptionHandler m
handleException :: ExceptionHandler m
isBatch :: Bool
getPrompt :: m String
getBanner :: String
getHistory :: Maybe String
handleException :: forall (m :: * -> *). Settings m -> ExceptionHandler m
isBatch :: forall (m :: * -> *). Settings m -> Bool
getPrompt :: forall (m :: * -> *). Settings m -> m String
getBanner :: forall (m :: * -> *). Settings m -> String
getHistory :: forall (m :: * -> *). Settings m -> Maybe String
..} =
CompletionFunc (StateM m)
-> Settings (StateM m) -> Settings (StateM m)
forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
HL.setComplete CompletionFunc (StateM m)
forall (m :: * -> *). Monad m => CompletionFunc (StateM m)
explorer Settings (StateM m)
forall (m :: * -> *). MonadIO m => Settings m
HL.defaultSettings { historyFile :: Maybe String
HL.historyFile = Maybe String
getHistory }
runCLI :: (MonadMask m, MonadIO m)
=> String
-> Settings m
-> CommandsT m a
-> m (Either CLIException a)
runCLI :: String -> Settings m -> CommandsT m a -> m (Either CLIException a)
runCLI String
name settings :: Settings m
settings@Settings{m String
Bool
String
Maybe String
ExceptionHandler m
handleException :: ExceptionHandler m
isBatch :: Bool
getPrompt :: m String
getBanner :: String
getHistory :: Maybe String
handleException :: forall (m :: * -> *). Settings m -> ExceptionHandler m
isBatch :: forall (m :: * -> *). Settings m -> Bool
getPrompt :: forall (m :: * -> *). Settings m -> m String
getBanner :: forall (m :: * -> *). Settings m -> String
getHistory :: forall (m :: * -> *). Settings m -> Maybe String
..} CommandsT m a
commands = do
(a
value, [Node m]
root) <- CommandsT m a -> m (a, [Node m])
forall (m :: * -> *) a. CommandsT m a -> m (a, [Node m])
runCommandsT CommandsT m a
commands
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isBatch) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
getBanner
let ?settings = settings
[Node m]
-> StateT (State m) m (Either CLIException a)
-> m (Either CLIException a)
forall (m :: * -> *) (m :: * -> *) a.
(Monad m, Monad m) =>
[Node m] -> StateT (State m) m a -> m a
withStateM [Node m]
root (StateT (State m) m (Either CLIException a)
-> m (Either CLIException a))
-> (ExceptT CLIException (InputT (StateM m)) a
-> StateT (State m) m (Either CLIException a))
-> ExceptT CLIException (InputT (StateM m)) a
-> m (Either CLIException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings (StateM m)
-> InputT (StateM m) (Either CLIException a)
-> StateT (State m) m (Either CLIException a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
HL.runInputT Settings (StateM m)
hLineSettings (InputT (StateM m) (Either CLIException a)
-> StateT (State m) m (Either CLIException a))
-> (ExceptT CLIException (InputT (StateM m)) a
-> InputT (StateM m) (Either CLIException a))
-> ExceptT CLIException (InputT (StateM m)) a
-> StateT (State m) m (Either CLIException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT CLIException (InputT (StateM m)) a
-> InputT (StateM m) (Either CLIException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CLIException (InputT (StateM m)) a
-> m (Either CLIException a))
-> ExceptT CLIException (InputT (StateM m)) a
-> m (Either CLIException a)
forall a b. (a -> b) -> a -> b
$ do
ExceptT CLIException (InputT (StateM m)) ()
loop
a -> ExceptT CLIException (InputT (StateM m)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value
where hLineSettings :: Settings (StateM m)
hLineSettings = Settings m -> Settings (StateM m)
forall (m :: * -> *).
MonadIO m =>
Settings m -> Settings (StateM m)
hLineSettingsFrom Settings m
settings
withStateM :: [Node m] -> StateT (State m) m a -> m a
withStateM [Node m]
root = (StateT (State m) m a -> State m -> m a)
-> State m -> StateT (State m) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (State m) m a -> State m -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (State m -> StateT (State m) m a -> m a)
-> State m -> StateT (State m) m a -> m a
forall a b. (a -> b) -> a -> b
$ [Node m] -> State m
forall (m :: * -> *). Monad m => [Node m] -> State m
state0 [Node m]
root
processInput :: ExceptT CLIException (InputT (StateM m)) b
processInput = do
let ?settings = settings
State m
state <- StateM m (State m) -> ParserT m (State m)
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM StateM m (State m)
forall s (m :: * -> *). MonadState s m => m s
get
ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *).
(?settings::Settings m, MonadMask m, MonadIO m) =>
ParserT m ()
runLevel ExceptT CLIException (InputT (StateM m)) ()
-> (CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> ExceptT CLIException (InputT (StateM m)) ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \CLIException
e -> do
StateM m () -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m () -> ExceptT CLIException (InputT (StateM m)) ())
-> StateM m () -> ExceptT CLIException (InputT (StateM m)) ()
forall a b. (a -> b) -> a -> b
$ State m -> StateM m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put State m
state
CLIException -> ExceptT CLIException (InputT (StateM m)) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CLIException
e
ExceptT CLIException (InputT (StateM m)) b
processInput
dummyParser :: p -> p -> String -> m (ParseResult a)
dummyParser p
_ = \p
_ String
input ->
ParseResult a -> m (ParseResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult a -> m (ParseResult a))
-> ParseResult a -> m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> ParseResult a
forall a. [(String, String)] -> String -> ParseResult a
Partial [] String
input
state0 :: [Node m] -> State m
state0 [Node m]
root = [Level m] -> State m
forall (m :: * -> *). [Level m] -> State m
State [(String
name, [Node m] -> Node m
forall (m :: * -> *). Monad m => [Node m] -> Node m
mkNode [Node m]
root)]
mkNode :: [Node m] -> Node m
mkNode [Node m]
root = Node :: forall (m :: * -> *) a.
String
-> String
-> [Node m]
-> Parser m a
-> m Bool
-> Handler m a
-> Node m
Node {
getLabel :: String
getLabel = String
name,
getHint :: String
getHint = String
forall a. Monoid a => a
mempty,
getBranches :: [Node m]
getBranches = [Node m]
root,
runParser :: Parser m Any
runParser = [Node m] -> Parser m Any
forall (m :: * -> *) p p a.
Monad m =>
p -> p -> String -> m (ParseResult a)
dummyParser [Node m]
root,
isEnabled :: m Bool
isEnabled = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
handle :: Handler m Any
handle = m Action -> Handler m Any
forall a b. a -> b -> a
const (m Action -> Handler m Any)
-> (Action -> m Action) -> Action -> Handler m Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return (Action -> Handler m Any) -> Action -> Handler m Any
forall a b. (a -> b) -> a -> b
$ Action
NewLevel
}
loop :: ExceptT CLIException (InputT (StateM m)) ()
loop = do
ExceptT CLIException (InputT (StateM m)) ()
-> ExceptT CLIException (InputT (StateM m)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT CLIException (InputT (StateM m)) ()
-> ExceptT CLIException (InputT (StateM m)) ())
-> ((CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> ExceptT CLIException (InputT (StateM m)) ())
-> (CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> ExceptT CLIException (InputT (StateM m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT CLIException (InputT (StateM m)) ()
-> (CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> ExceptT CLIException (InputT (StateM m)) ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ExceptT CLIException (InputT (StateM m)) ()
forall b. ExceptT CLIException (InputT (StateM m)) b
processInput ((CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> ExceptT CLIException (InputT (StateM m)) ())
-> (CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> ExceptT CLIException (InputT (StateM m)) ()
forall a b. (a -> b) -> a -> b
$
\CLIException
e -> do
Either CLIException ()
exceptionResult <- m (Either CLIException ()) -> ParserT m (Either CLIException ())
forall (m :: * -> *) a. Monad m => m a -> ParserT m a
liftUserM (m (Either CLIException ()) -> ParserT m (Either CLIException ()))
-> m (Either CLIException ()) -> ParserT m (Either CLIException ())
forall a b. (a -> b) -> a -> b
$ ExceptionHandler m
handleException CLIException
e
(CLIException -> ExceptT CLIException (InputT (StateM m)) ())
-> (() -> ExceptT CLIException (InputT (StateM m)) ())
-> Either CLIException ()
-> ExceptT CLIException (InputT (StateM m)) ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CLIException -> ExceptT CLIException (InputT (StateM m)) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError () -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return Either CLIException ()
exceptionResult
ExceptT CLIException (InputT (StateM m)) ()
loop
defExceptionHandler :: (MonadIO m) => CLIException -> m (Either CLIException ())
defExceptionHandler :: CLIException -> m (Either CLIException ())
defExceptionHandler (SyntaxError String
str String
msg) = do
(() -> Either CLIException ())
-> m () -> m (Either CLIException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either CLIException ()
forall a b. b -> Either a b
Right (m () -> m (Either CLIException ()))
-> (String -> m ()) -> String -> m (Either CLIException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m (Either CLIException ()))
-> String -> m (Either CLIException ())
forall a b. (a -> b) -> a -> b
$ String
"SyntaxError at or around " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
defExceptionHandler (HelpRequested [(String, String)]
hints) =
(() -> Either CLIException ())
-> m () -> m (Either CLIException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either CLIException ()
forall a b. b -> Either a b
Right (m () -> m (Either CLIException ()))
-> (IO () -> m ()) -> IO () -> m (Either CLIException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m (Either CLIException ()))
-> IO () -> m (Either CLIException ())
forall a b. (a -> b) -> a -> b
$ do
((String, String) -> IO ()) -> [(String, String)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, String) -> IO ()
display ([(String, String)] -> IO ()) -> [(String, String)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, String)]
hints
String -> IO ()
putStrLn String
""
where display :: (String, String) -> IO ()
display (String
label, String
hint) =
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hint
defExceptionHandler CLIException
e =
Either CLIException () -> m (Either CLIException ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CLIException () -> m (Either CLIException ()))
-> (CLIException -> Either CLIException ())
-> CLIException
-> m (Either CLIException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLIException -> Either CLIException ()
forall a b. a -> Either a b
Left (CLIException -> m (Either CLIException ()))
-> CLIException -> m (Either CLIException ())
forall a b. (a -> b) -> a -> b
$ CLIException
e
runLevel :: (?settings::Settings m, MonadMask m, MonadIO m)
=> ParserT m ()
runLevel :: ParserT m ()
runLevel = do
String
prompt <- m String -> ParserT m String
forall (m :: * -> *) a. Monad m => m a -> ParserT m a
liftUserM (m String -> ParserT m String)
-> ([String] -> m String) -> [String] -> ParserT m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> m String
forall (f :: * -> *).
(Functor f, ?settings::Settings f) =>
[String] -> f String
buildPrompt ([String] -> ParserT m String)
-> ExceptT CLIException (InputT (StateM m)) [String]
-> ParserT m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT CLIException (InputT (StateM m)) [String]
withLabels
[Level m]
stack0 <- ParserT m [Level m]
forall (m :: * -> *). Monad m => ParserT m [Level m]
getStack
Maybe ()
result <- MaybeT (ExceptT CLIException (InputT (StateM m))) ()
-> ExceptT CLIException (InputT (StateM m)) (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ExceptT CLIException (InputT (StateM m))) ()
-> ExceptT CLIException (InputT (StateM m)) (Maybe ()))
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
-> ExceptT CLIException (InputT (StateM m)) (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
String
line <- ExceptT CLIException (InputT (StateM m)) (Maybe String)
-> MaybeT (ExceptT CLIException (InputT (StateM m))) String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ExceptT CLIException (InputT (StateM m)) (Maybe String)
-> MaybeT (ExceptT CLIException (InputT (StateM m))) String)
-> (InputT (StateM m) (Maybe String)
-> ExceptT CLIException (InputT (StateM m)) (Maybe String))
-> InputT (StateM m) (Maybe String)
-> MaybeT (ExceptT CLIException (InputT (StateM m))) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT (StateM m) (Maybe String)
-> ExceptT CLIException (InputT (StateM m)) (Maybe String)
forall (m :: * -> *) a.
Monad m =>
InputT (StateM m) a -> ParserT m a
liftInputT (InputT (StateM m) (Maybe String)
-> MaybeT (ExceptT CLIException (InputT (StateM m))) String)
-> InputT (StateM m) (Maybe String)
-> MaybeT (ExceptT CLIException (InputT (StateM m))) String
forall a b. (a -> b) -> a -> b
$ String -> InputT (StateM m) (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
HL.getInputLine String
prompt
Bool
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Settings m -> Bool
forall (m :: * -> *). Settings m -> Bool
isBatch ?settings::Settings m
Settings m
?settings) (MaybeT (ExceptT CLIException (InputT (StateM m))) ()
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ())
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
forall a b. (a -> b) -> a -> b
$ String -> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
printInput String
line
String -> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
forall (m :: * -> *). Monad m => String -> MaybeT (ParserT m) ()
process String
line
case Maybe ()
result of
Maybe ()
Nothing ->
if Settings m -> Bool
forall (m :: * -> *). Settings m -> Bool
isBatch ?settings::Settings m
Settings m
?settings
then CLIException -> ParserT m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CLIException
Exit
else [Level m] -> ParserT m ()
forall (m :: * -> *). Monad m => [Level m] -> ParserT m ()
restore [Level m]
stack0
Maybe ()
_ ->
() -> ParserT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where buildPrompt :: [String] -> f String
buildPrompt [String]
ns = ([String] -> String
showStack [String]
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings f -> f String
forall (m :: * -> *). Settings m -> m String
getPrompt ?settings::Settings f
Settings f
?settings
withLabels :: ExceptT CLIException (InputT (StateM m)) [String]
withLabels = (Level m -> String) -> [Level m] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Level m -> String
forall a b. (a, b) -> a
fst ([Level m] -> [String])
-> ParserT m [Level m]
-> ExceptT CLIException (InputT (StateM m)) [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserT m [Level m]
forall (m :: * -> *). Monad m => ParserT m [Level m]
getStack
restore :: [Level m] -> ParserT m ()
restore [Level m]
stack = StateM m () -> ParserT m ()
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m () -> ParserT m ())
-> ((State m -> State m) -> StateM m ())
-> (State m -> State m)
-> ParserT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State m -> State m) -> StateM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> ParserT m ())
-> (State m -> State m) -> ParserT m ()
forall a b. (a -> b) -> a -> b
$ \State m
s -> State m
s { stack :: [Level m]
stack = [Level m]
stack }
showStack :: [String] -> String
showStack = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse
printInput :: String -> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
printInput = ParserT m ()
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParserT m ()
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ())
-> (String -> ParserT m ())
-> String
-> MaybeT (ExceptT CLIException (InputT (StateM m))) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT (StateM m) () -> ParserT m ()
forall (m :: * -> *) a.
Monad m =>
InputT (StateM m) a -> ParserT m a
liftInputT (InputT (StateM m) () -> ParserT m ())
-> (String -> InputT (StateM m) ()) -> String -> ParserT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InputT (StateM m) ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
HL.outputStrLn
getStack :: (Monad m) => ParserT m [Level m]
getStack :: ParserT m [Level m]
getStack = StateM m [Level m] -> ParserT m [Level m]
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m [Level m] -> ParserT m [Level m])
-> StateM m [Level m] -> ParserT m [Level m]
forall a b. (a -> b) -> a -> b
$ (State m -> [Level m]) -> StateM m [Level m]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets State m -> [Level m]
forall (m :: * -> *). State m -> [Level m]
stack
process :: (Monad m) => String -> MaybeT (ParserT m) ()
process :: String -> MaybeT (ParserT m) ()
process String
input = ExceptT CLIException (InputT (StateM m)) ()
-> MaybeT (ParserT m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT CLIException (InputT (StateM m)) ()
-> MaybeT (ParserT m) ())
-> ExceptT CLIException (InputT (StateM m)) ()
-> MaybeT (ParserT m) ()
forall a b. (a -> b) -> a -> b
$ do
[Level m]
stack0 <- ParserT m [Level m]
forall (m :: * -> *). Monad m => ParserT m [Level m]
getStack
Node m
node <- ParserT m (Node m)
forall (m :: * -> *). Monad m => ParserT m (Node m)
getCurrentNode
Action
action <- String -> Node m -> Action -> ParserT m Action
forall (m :: * -> *).
Monad m =>
String -> Node m -> Action -> ParserT m Action
process' String
input Node m
node Action
NewLevel
case Action
action of
Action
NewLevel ->
() -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
LevelUp Int
n ->
Int -> [Level m] -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
Int -> t a -> ExceptT CLIException (InputT (StateM m)) ()
levelUp Int
n [Level m]
stack0
Action
NoAction ->
Int -> [Level m] -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
Int -> t a -> ExceptT CLIException (InputT (StateM m)) ()
levelUp Int
0 [Level m]
stack0
Action
ToRoot ->
Int -> [Level m] -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
Int -> t a -> ExceptT CLIException (InputT (StateM m)) ()
levelUp (-Int
forall a. Bounded a => a
maxBound) [Level m]
stack0
where levelUp :: Int -> t a -> ExceptT CLIException (InputT (StateM m)) ()
levelUp Int
levels t a
stack0 = do
[Level m]
stack <- ParserT m [Level m]
forall (m :: * -> *). Monad m => ParserT m [Level m]
getStack
let depth :: Int
depth = [Level m] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Level m]
stack
depth0 :: Int
depth0 = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
stack0
depth' :: Int
depth' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
depth0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
levels
to :: Int
to = Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
depth'
Int
-> ExceptT CLIException (InputT (StateM m)) ()
-> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
to ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *). Monad m => ParserT m ()
pop
process' :: (Monad m) => String -> Node m -> Action -> ParserT m Action
process' :: String -> Node m -> Action -> ParserT m Action
process' String
"" Node m
_ Action
action =
Action -> ParserT m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
action
process' (Char
' ':String
remaining) Node m
node Action
action =
String -> Node m -> Action -> ParserT m Action
forall (m :: * -> *).
Monad m =>
String -> Node m -> Action -> ParserT m Action
process' String
remaining Node m
node Action
action
process' String
input Node m
currentNode Action
_ = do
String -> ExceptT CLIException (InputT (StateM m)) ()
forall (f :: * -> *). Applicative f => String -> f ()
debugM (String -> ExceptT CLIException (InputT (StateM m)) ())
-> String -> ExceptT CLIException (InputT (StateM m)) ()
forall a b. (a -> b) -> a -> b
$ String
"processing " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
input String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Node m -> String
forall (m :: * -> *). Node m -> String
getLabel Node m
currentNode
[SearchResult m]
result <- StateM m [SearchResult m] -> ParserT m [SearchResult m]
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m [SearchResult m] -> ParserT m [SearchResult m])
-> StateM m [SearchResult m] -> ParserT m [SearchResult m]
forall a b. (a -> b) -> a -> b
$ Node m -> String -> StateM m [SearchResult m]
forall (m :: * -> *).
Monad m =>
Node m -> String -> StateM m [SearchResult m]
findNext Node m
currentNode String
input
case (SearchResult m -> Bool) -> [SearchResult m] -> [SearchResult m]
forall a. (a -> Bool) -> [a] -> [a]
filter SearchResult m -> Bool
forall (m :: * -> *). Monad m => SearchResult m -> Bool
isCompleted [SearchResult m]
result of
(Completed{ completedNode :: forall (m :: * -> *). SearchResult m -> Node m
completedNode=node :: Node m
node@Node{m Bool
String
[Node m]
Handler m a
Parser m a
handle :: Handler m a
isEnabled :: m Bool
runParser :: Parser m a
getBranches :: [Node m]
getHint :: String
getLabel :: String
handle :: ()
isEnabled :: forall (m :: * -> *). Node m -> m Bool
runParser :: ()
getBranches :: forall (m :: * -> *). Node m -> [Node m]
getHint :: forall (m :: * -> *). Node m -> String
getLabel :: forall (m :: * -> *). Node m -> String
..}, m Action
String
completedRemaining :: String
completedMatched :: String
completedAction :: m Action
completedRemaining :: forall (m :: * -> *). SearchResult m -> String
completedMatched :: forall (m :: * -> *). SearchResult m -> String
completedAction :: forall (m :: * -> *). SearchResult m -> m Action
..}:[SearchResult m]
_) -> do
String -> Node m -> ExceptT CLIException (InputT (StateM m)) ()
forall (m :: * -> *). Monad m => String -> Node m -> ParserT m ()
push String
completedMatched Node m
node
Action
action <- m Action -> ParserT m Action
forall (m :: * -> *) a. Monad m => m a -> ParserT m a
liftUserM m Action
completedAction
String -> Node m -> Action -> ParserT m Action
forall (m :: * -> *).
Monad m =>
String -> Node m -> Action -> ParserT m Action
process' String
completedRemaining Node m
node Action
action
[SearchResult m]
_ ->
if String -> Bool
checkForHelp (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
input then do
let hints :: [(String, String)]
hints = ([(String, String)] -> SearchResult m -> [(String, String)])
-> [(String, String)] -> [SearchResult m] -> [(String, String)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [(String, String)] -> SearchResult m -> [(String, String)]
forall (m :: * -> *).
Monad m =>
[(String, String)] -> SearchResult m -> [(String, String)]
getHelp [] [SearchResult m]
result
String -> ExceptT CLIException (InputT (StateM m)) ()
forall (f :: * -> *). Applicative f => String -> f ()
debugM (String -> ExceptT CLIException (InputT (StateM m)) ())
-> String -> ExceptT CLIException (InputT (StateM m)) ()
forall a b. (a -> b) -> a -> b
$ String
"help requested: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
forall a. Show a => a -> String
show [(String, String)]
hints
CLIException -> ParserT m Action
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CLIException -> ParserT m Action)
-> ([(String, String)] -> CLIException)
-> [(String, String)]
-> ParserT m Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> CLIException
HelpRequested ([(String, String)] -> ParserT m Action)
-> [(String, String)] -> ParserT m Action
forall a b. (a -> b) -> a -> b
$ [(String, String)]
hints
else
case (SearchResult m -> Bool) -> [SearchResult m] -> [SearchResult m]
forall a. (a -> Bool) -> [a] -> [a]
filter SearchResult m -> Bool
forall (m :: * -> *). Monad m => SearchResult m -> Bool
isFailed [SearchResult m]
result of
Failed{String
Node m
failedRemaining :: String
failedMsg :: String
failedNode :: Node m
failedRemaining :: forall (m :: * -> *). SearchResult m -> String
failedMsg :: forall (m :: * -> *). SearchResult m -> String
failedNode :: forall (m :: * -> *). SearchResult m -> Node m
..}:[SearchResult m]
_ ->
CLIException -> ParserT m Action
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CLIException -> ParserT m Action)
-> (String -> CLIException) -> String -> ParserT m Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> CLIException
SyntaxError String
input (String -> ParserT m Action) -> String -> ParserT m Action
forall a b. (a -> b) -> a -> b
$ String
failedMsg
[SearchResult m]
_ ->
case (SearchResult m -> Bool) -> [SearchResult m] -> [SearchResult m]
forall a. (a -> Bool) -> [a] -> [a]
filter SearchResult m -> Bool
forall (m :: * -> *). Monad m => SearchResult m -> Bool
isIncomplete [SearchResult m]
result of
Incomplete{[(String, String)]
Node m
incompleteHints :: [(String, String)]
incompleteNode :: Node m
incompleteHints :: forall (m :: * -> *). SearchResult m -> [(String, String)]
incompleteNode :: forall (m :: * -> *). SearchResult m -> Node m
..}:[SearchResult m]
_ ->
CLIException -> ParserT m Action
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CLIException -> ParserT m Action)
-> ([(String, String)] -> CLIException)
-> [(String, String)]
-> ParserT m Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> CLIException
SyntaxError String
input (String -> CLIException)
-> ([(String, String)] -> String)
-> [(String, String)]
-> CLIException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String)
-> ([(String, String)] -> (String, String))
-> [(String, String)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> (String, String)
forall a. [a] -> a
head ([(String, String)] -> ParserT m Action)
-> [(String, String)] -> ParserT m Action
forall a b. (a -> b) -> a -> b
$ [(String, String)]
incompleteHints
[SearchResult m]
_ ->
CLIException -> ParserT m Action
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CLIException -> ParserT m Action)
-> (String -> CLIException) -> String -> ParserT m Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> CLIException
SyntaxError String
input (String -> ParserT m Action) -> String -> ParserT m Action
forall a b. (a -> b) -> a -> b
$ String
""
where checkForHelp :: String -> Bool
checkForHelp (Char
'?':String
_) = Bool
True
checkForHelp String
_ = Bool
False
getHelp :: [(String, String)] -> SearchResult m -> [(String, String)]
getHelp [(String, String)]
acc Failed{String
Node m
failedRemaining :: String
failedMsg :: String
failedNode :: Node m
failedRemaining :: forall (m :: * -> *). SearchResult m -> String
failedMsg :: forall (m :: * -> *). SearchResult m -> String
failedNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = (Node m -> String
forall (m :: * -> *). Node m -> String
getLabel Node m
failedNode, String
failedMsg)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
acc
getHelp [(String, String)]
acc Incomplete{[(String, String)]
Node m
incompleteHints :: [(String, String)]
incompleteNode :: Node m
incompleteHints :: forall (m :: * -> *). SearchResult m -> [(String, String)]
incompleteNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = [(String, String)]
incompleteHints [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
acc
getHelp [(String, String)]
acc Completed{m Action
String
Node m
completedRemaining :: String
completedMatched :: String
completedAction :: m Action
completedNode :: Node m
completedRemaining :: forall (m :: * -> *). SearchResult m -> String
completedMatched :: forall (m :: * -> *). SearchResult m -> String
completedAction :: forall (m :: * -> *). SearchResult m -> m Action
completedNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = Node m -> (String, String)
forall (m :: * -> *). Monad m => Node m -> (String, String)
help Node m
completedNode (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
acc
getHelp [(String, String)]
acc SearchResult m
_ = [(String, String)]
acc
help :: (Monad m) => Node m -> (String , String)
help :: Node m -> (String, String)
help Node{m Bool
String
[Node m]
Handler m a
Parser m a
handle :: Handler m a
isEnabled :: m Bool
runParser :: Parser m a
getBranches :: [Node m]
getHint :: String
getLabel :: String
handle :: ()
isEnabled :: forall (m :: * -> *). Node m -> m Bool
runParser :: ()
getBranches :: forall (m :: * -> *). Node m -> [Node m]
getHint :: forall (m :: * -> *). Node m -> String
getLabel :: forall (m :: * -> *). Node m -> String
..} = (String
getLabel, String
getHint)
push :: (Monad m) => String -> Node m -> ParserT m ()
push :: String -> Node m -> ParserT m ()
push String
label Node m
node =
StateM m () -> ParserT m ()
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m () -> ParserT m ())
-> ((State m -> State m) -> StateM m ())
-> (State m -> State m)
-> ParserT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State m -> State m) -> StateM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> ParserT m ())
-> (State m -> State m) -> ParserT m ()
forall a b. (a -> b) -> a -> b
$ \s :: State m
s@State{[Level m]
stack :: [Level m]
stack :: forall (m :: * -> *). State m -> [Level m]
..} ->
State m
s { stack :: [Level m]
stack = (String
label, Node m
node) Level m -> [Level m] -> [Level m]
forall a. a -> [a] -> [a]
: [Level m]
stack }
pop :: (Monad m) => ParserT m ()
pop :: ParserT m ()
pop = do
[Level m]
stack <- StateM m [Level m] -> ParserT m [Level m]
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m [Level m] -> ParserT m [Level m])
-> StateM m [Level m] -> ParserT m [Level m]
forall a b. (a -> b) -> a -> b
$ (State m -> [Level m]) -> StateM m [Level m]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets State m -> [Level m]
forall (m :: * -> *). State m -> [Level m]
stack
case [Level m]
stack of
(Level m
_:[Level m]
remaining) ->
StateM m () -> ParserT m ()
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m () -> ParserT m ()) -> StateM m () -> ParserT m ()
forall a b. (a -> b) -> a -> b
$ (State m -> State m) -> StateM m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> StateM m ())
-> (State m -> State m) -> StateM m ()
forall a b. (a -> b) -> a -> b
$ \State m
s -> State m
s { stack :: [Level m]
stack = [Level m]
remaining }
[] ->
CLIException -> ParserT m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CLIException -> ParserT m ())
-> (String -> CLIException) -> String -> ParserT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLIException
InvalidOperation (String -> ParserT m ()) -> String -> ParserT m ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid attempt to pop element from empty command stack"
getCurrentNode :: (Monad m) => ParserT m (Node m)
getCurrentNode :: ParserT m (Node m)
getCurrentNode = do
[Level m]
stack <- StateM m [Level m] -> ParserT m [Level m]
forall (m :: * -> *) a. Monad m => StateM m a -> ParserT m a
liftStateM (StateM m [Level m] -> ParserT m [Level m])
-> StateM m [Level m] -> ParserT m [Level m]
forall a b. (a -> b) -> a -> b
$ (State m -> [Level m]) -> StateM m [Level m]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets State m -> [Level m]
forall (m :: * -> *). State m -> [Level m]
stack
case [Level m]
stack of
((String
_, Node m
node):[Level m]
_) -> Node m -> ParserT m (Node m)
forall (m :: * -> *) a. Monad m => a -> m a
return Node m
node
[] -> CLIException -> ParserT m (Node m)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CLIException -> ParserT m (Node m))
-> (String -> CLIException) -> String -> ParserT m (Node m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLIException
InternalError (String -> ParserT m (Node m)) -> String -> ParserT m (Node m)
forall a b. (a -> b) -> a -> b
$ String
"Empty command stack"
findNext :: (Monad m) => Node m -> String -> StateM m [SearchResult m]
findNext :: Node m -> String -> StateM m [SearchResult m]
findNext Node m
root String
input = do
(SearchResult m -> Bool) -> [SearchResult m] -> [SearchResult m]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (SearchResult m -> Bool) -> SearchResult m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchResult m -> Bool
forall (m :: * -> *). Monad m => SearchResult m -> Bool
isNoResult) ([SearchResult m] -> [SearchResult m])
-> StateM m [SearchResult m] -> StateM m [SearchResult m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node m -> StateT (State m) m (SearchResult m))
-> [Node m] -> StateM m [SearchResult m]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Node m -> StateT (State m) m (SearchResult m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m, Monad (t m)) =>
Node m -> t m (SearchResult m)
matching [Node m]
branches
where matching :: Node m -> t m (SearchResult m)
matching node :: Node m
node@Node{m Bool
String
[Node m]
Handler m a
Parser m a
handle :: Handler m a
isEnabled :: m Bool
runParser :: Parser m a
getBranches :: [Node m]
getHint :: String
getLabel :: String
handle :: ()
isEnabled :: forall (m :: * -> *). Node m -> m Bool
runParser :: ()
getBranches :: forall (m :: * -> *). Node m -> [Node m]
getHint :: forall (m :: * -> *). Node m -> String
getLabel :: forall (m :: * -> *). Node m -> String
..} = do
Bool
enabled <- m Bool -> t m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
isEnabled
if Bool
enabled then do
ParseResult a
result <- m (ParseResult a) -> t m (ParseResult a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (ParseResult a) -> t m (ParseResult a))
-> m (ParseResult a) -> t m (ParseResult a)
forall a b. (a -> b) -> a -> b
$ Parser m a
runParser Node m
node String
input
case ParseResult a
result of
Done a
output String
matched String
rest ->
SearchResult m -> t m (SearchResult m)
forall (m :: * -> *) a. Monad m => a -> m a
return Completed :: forall (m :: * -> *).
Node m -> m Action -> String -> String -> SearchResult m
Completed { completedNode :: Node m
completedNode = Node m
node,
completedAction :: m Action
completedAction = Handler m a
handle a
output,
completedMatched :: String
completedMatched = String
matched,
completedRemaining :: String
completedRemaining = String
rest }
Fail String
msg String
rest ->
SearchResult m -> t m (SearchResult m)
forall (m :: * -> *) a. Monad m => a -> m a
return Failed :: forall (m :: * -> *). Node m -> String -> String -> SearchResult m
Failed { failedNode :: Node m
failedNode = Node m
node,
failedMsg :: String
failedMsg = String
msg,
failedRemaining :: String
failedRemaining = String
rest }
Partial [(String, String)]
hints String
_ ->
SearchResult m -> t m (SearchResult m)
forall (m :: * -> *) a. Monad m => a -> m a
return Incomplete :: forall (m :: * -> *).
Node m -> [(String, String)] -> SearchResult m
Incomplete { incompleteNode :: Node m
incompleteNode = Node m
node,
incompleteHints :: [(String, String)]
incompleteHints = [(String, String)]
hints }
ParseResult a
NoMatch ->
SearchResult m -> t m (SearchResult m)
forall (m :: * -> *) a. Monad m => a -> m a
return SearchResult m
forall (m :: * -> *). SearchResult m
NoResult
else
SearchResult m -> t m (SearchResult m)
forall (m :: * -> *) a. Monad m => a -> m a
return SearchResult m
forall (m :: * -> *). SearchResult m
NoResult
branches :: [Node m]
branches = Node m -> [Node m]
forall (m :: * -> *). Node m -> [Node m]
getBranches Node m
root
explorer :: (Monad m) => HL.CompletionFunc (StateM m)
explorer :: CompletionFunc (StateM m)
explorer input :: (String, String)
input@(String
tfel, String
_) = do
[Level m]
currentLevel <- (State m -> [Level m]) -> StateT (State m) m [Level m]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets State m -> [Level m]
forall (m :: * -> *). State m -> [Level m]
stack
[String]
possibilities <- case [Level m]
currentLevel of
(String
_, Node m
currentNode):[Level m]
_ ->
[String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> StateT (State m) m [String] -> StateT (State m) m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node m -> String -> StateT (State m) m [String]
forall (m :: * -> *).
Monad m =>
Node m -> String -> StateM m [String]
getPossibilities Node m
currentNode String
left
[Level m]
_ ->
[String] -> StateT (State m) m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
let complete :: CompletionFunc (StateM m)
complete = Maybe Char
-> String
-> (String -> StateT (State m) m [Completion])
-> CompletionFunc (StateM m)
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
HL.completeWord Maybe Char
forall a. Maybe a
Nothing String
" " ((String -> StateT (State m) m [Completion])
-> CompletionFunc (StateM m))
-> (String -> StateT (State m) m [Completion])
-> CompletionFunc (StateM m)
forall a b. (a -> b) -> a -> b
$ \String
str ->
[Completion] -> StateT (State m) m [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Completion] -> StateT (State m) m [Completion])
-> [Completion] -> StateT (State m) m [Completion]
forall a b. (a -> b) -> a -> b
$ (String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
HL.simpleCompletion ([String] -> [Completion]) -> [String] -> [Completion]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
str String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
possibilities
CompletionFunc (StateM m)
complete (String, String)
input
where left :: String
left = ShowS
forall a. [a] -> [a]
reverse String
tfel
getPossibilities :: (Monad m) => Node m -> String -> StateM m [String]
getPossibilities :: Node m -> String -> StateM m [String]
getPossibilities Node m
root String
input = do
[SearchResult m]
results <- Node m -> String -> StateM m [SearchResult m]
forall (m :: * -> *).
Monad m =>
Node m -> String -> StateM m [SearchResult m]
findNext Node m
root String
input
case (SearchResult m -> Bool) -> [SearchResult m] -> [SearchResult m]
forall a. (a -> Bool) -> [a] -> [a]
filter SearchResult m -> Bool
forall (m :: * -> *). Monad m => SearchResult m -> Bool
isCompleted [SearchResult m]
results of
(SearchResult m
_:SearchResult m
_:[SearchResult m]
_) ->
[String] -> StateM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Completed{m Action
String
Node m
completedRemaining :: String
completedMatched :: String
completedAction :: m Action
completedNode :: Node m
completedRemaining :: forall (m :: * -> *). SearchResult m -> String
completedMatched :: forall (m :: * -> *). SearchResult m -> String
completedAction :: forall (m :: * -> *). SearchResult m -> m Action
completedNode :: forall (m :: * -> *). SearchResult m -> Node m
..}:[] ->
Node m -> String -> StateM m [String]
forall (m :: * -> *).
Monad m =>
Node m -> String -> StateM m [String]
getPossibilities Node m
completedNode String
completedRemaining
[SearchResult m]
_ ->
[String] -> StateM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> StateM m [String]) -> [String] -> StateM m [String]
forall a b. (a -> b) -> a -> b
$ (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(String, String)] -> SearchResult m -> [(String, String)])
-> [(String, String)] -> [SearchResult m] -> [(String, String)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [(String, String)] -> SearchResult m -> [(String, String)]
forall (m :: * -> *).
[(String, String)] -> SearchResult m -> [(String, String)]
getPossibilities' [] [SearchResult m]
results
where getPossibilities' :: [(String, String)] -> SearchResult m -> [(String, String)]
getPossibilities' [(String, String)]
acc Incomplete{[(String, String)]
Node m
incompleteHints :: [(String, String)]
incompleteNode :: Node m
incompleteHints :: forall (m :: * -> *). SearchResult m -> [(String, String)]
incompleteNode :: forall (m :: * -> *). SearchResult m -> Node m
..} = ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String, String) -> Bool
forall b. (String, b) -> Bool
notEmpty [(String, String)]
incompleteHints [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
acc
getPossibilities' [(String, String)]
acc SearchResult m
_ = [(String, String)]
acc
notEmpty :: (String, b) -> Bool
notEmpty (String
"", b
_) = Bool
False
notEmpty (String
_, b
_) = Bool
True