{-# LANGUAGE CPP,
             ImplicitParams,
             ExistentialQuantification,
             FlexibleContexts,
             FlexibleInstances,
             RecordWildCards,
             TupleSections,
             TypeSynonymInstances #-}
-----------------------------------------------------------------------------
{- |
Module: System.Console.StructuredCLI
Description: Application library for building interactive console CLIs
Copyright: (c) Erick Gonzalez, 2017-2018
License: BSD3
Maintainer: erick@codemonkeylabs.de

This module provides the tools to build a complete "structured" CLI application, similar
to those found in systems like Cisco IOS or console configuration utilities etc. It aims
to be easy for implementors to use.

-}
module System.Console.StructuredCLI (
-- * How to use this module:
-- |
-- It is often the case that a simple example is the best user guide, at least for the
-- experienced programmer. The following code illustrates a basic but functioning CLI application
--
-- @
-- module Main where
--
-- import Control.Monad                 (void)
-- import Control.Monad.IO.Class        (liftIO)
-- import Data.Default                  (def)
-- import System.Console.StructuredCLI
--
-- root :: Commands ()
-- root = do
--   world >+ do
--     hello
--     bye
--     command "exit" "return to previous level" exit
--
-- world :: Commands ()
-- world = command "world" "enter into the world" $ return NewLevel
--
-- hello :: Commands ()
-- hello = command "hello" "prints a greeting" $ do
--           liftIO . putStrLn $ "Hello world!"
--           return NoAction
--
-- bye :: Commands ()
-- bye = command "bye" "say goodbye" $ do
--         liftIO . putStrLn $ "Sayonara!"
--         return NoAction
--
-- main :: IO ()
-- main = void $ runCLI "Hello CLI" def root
-- @
--
-- resulting example CLI session:
--
-- >>> Hello CLI > ?
-- - world: enter into the world
--
-- >>> Hello CLI > world
-- >>> Hello CLI world > ?
-- - exit: return to previous level
-- - bye: say goodbye
-- - hello: prints a greeting
--
-- >>> Hello CLI world > hello
-- Hello world!
-- >>> Hello CLI world > bye
-- Sayonara!
-- >>> Hello CLI world > exit
-- >>> Hello CLI >
--
-- A good way to get you started is to grab the example code available under <http://gitlab.com/codemonkeylabs/structured-cli/blob/master/example/Main.hs example/Main.hs> and modify it to suit your needs.
                                     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

-- | An 'Action' is returned as the result of a command handler provided by the user and
-- it instructs the CLI of any changes in the CLI state
data Action
    -- | The command executed is "entered" into, creating a new CLI level.
    = NewLevel
    -- | Do not enter a new level.
    | NoAction
    -- | Reset the CLI state up to a given number of levels.
    | LevelUp Int
    -- | Go back up all the way to the top (root) of the CLI.
    | 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)

-- | The 'Node' type contains the internal representation of a command. Normally there is no
-- need to be concerned with it other than perhaps passing it opaquely to any utility parsers
-- (like 'labelParser' for example), when writing a custom parser
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)

-- | A 'Validator' is a function to which a parsed string is given in order to perform
-- any checks for validity that may be applicable, or even transforming the argument if
-- necessary. Note that the validator runs in the "user" monad
type Validator m a = String -> m (Maybe a)

type ExceptionHandler m = CLIException -> m (Either CLIException ())

-- | There is no need to concern oneself with the 'ParseResult' type unless one is writing
-- a custom parser, which should actually be rarer than not.
data ParseResult a =
    Done {
      -- | Output (parsed) value to be fed to the command action handler
      ParseResult a -> a
getOutput :: a,
      -- | Part of the string matched during parsing of a command
      ParseResult a -> String
getDoneMatched :: String,
      -- | Remaining input data
      ParseResult a -> String
getDoneRemaining :: String }
  | Partial {
      -- | List of possible completions along with a corresponding help string
      ParseResult a -> [(String, String)]
getPartialHints :: [(String, String)],
      -- | Remaining input data
      ParseResult a -> String
getPartialRemaining :: String }
  | Fail {
      -- | A message string containing a possible hint for correct useage
      ParseResult a -> String
getFailMessage :: String,
      -- | Remaining input data
      ParseResult a -> String
getFailRemaining :: String }
  -- | Parsing provided input doesnt match this command. The difference between 'Fail' and
  -- 'NoMatch' is a fine but important one. Failure should be used for example when a command
  -- keyword is correct but a required parameter is invalid or contains an error for example.
  -- A 'NoMatch' should be exclusively used when a command keyword does not correspond to the
  -- given input
  | 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
    -- | CLI Settings provided upon launching the CLI. It is recommended to modify
    -- the settings provided by the 'Default' instance: i.e:
    -- @
    -- def { getBanner = "My CLI" }
    -- @
    -- that way you can use for example the default exception handler which should suit
    -- usual needs, etc.
    = Settings {
      -- | An optional filename to activate and store the CLI command history function
      Settings m -> Maybe String
getHistory      :: Maybe FilePath,
      -- | Text to display upon start of the CLI application
      Settings m -> String
getBanner       :: String,
      -- | Prompt characters to display to the right of the current command "stack"
      Settings m -> m String
getPrompt       :: m String,
      -- | Disable prompt for use with batch scripts
      Settings m -> Bool
isBatch         :: Bool,
      -- | Exception handler
      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

-- | The 'CommandsT' transformer monad is the key to building a CLI tree. It is meant to
-- be used as a transformer wrapping an application specific "user" monad (for example, a 'State'
-- monad encapsulating application state). This monad is executed _once_ upon calling 'runCLI'
-- to build the command tree. Keep in mind however that any parsers or actions used in
-- any given command all run in the "user" monad and unlike the process of building the command
-- tree, they will be called multiple times as the user navigates the CLI at runtime.
-- Each 'CommandsT' monadic action corresponds to a single "node" (a.k.a. command) in the CLI.
-- Succesive actions simply add commands to the current "level". It is possible to "nest"
-- a new level to a command by using the '(>+)' operator. When properly indented (see example code
-- above) it provides a pretty self explanatory way to build the CLI tree.
newtype CommandsT m a = CommandsT { CommandsT m a -> m (a, [Node m])
runCommandsT :: m (a, [Node m]) }

-- | An alias type for the case where CommandsT wraps IO only (i.e. no state, etc)
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

-- | the CommandsT "nest" operation. It adds a new deeper CLI level to the command on the left
-- side with the commands on the right side, for example:
-- @
-- activate >+ do
--   foo
--   bar
--   baz
-- @
-- Would result in the following CLI command structure:
--
-- >>> > activate
-- >>> activate > ?
-- >>> - foo ..
-- >>> - bar ..
-- >>> - baz ..
(>+) :: (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 }])

-- | Build a command node that is always active and takes no parameters
command :: (Monad m) => String    -- ^ Command keyword
                     -> String    -- ^ Help text for this command
                     -> m Action  -- ^ Action in the "user" monad (i.e. @return NewLevel@)
                     -> 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

-- | A variation of 'command' that allows for "disabling" the command at runtime by
-- running the given "enable" monadic action (as always in the "user" monad) to check
-- if the command should be displayed as an option and/or accepted or not.
command' :: (Monad m) => String    -- ^ Command keyword
                      -> String    -- ^ Help text for this command
                      -> m Bool    -- ^ Enable action in the "user" monad
                      -> m Action  -- ^ Action in the "user" monad (i.e. @return NewLevel@)
                      -> 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

-- | Build a command node that takes one parameter (delimited by space). The parsed parameter
-- is fed to the validator monadic function (in the "user" monad) and the resulting value
-- if any is fed in turn as an argument to the handler action (also in the "user" monad).
param :: (Monad m) => String         -- ^ Command keyword
                   -> String         -- ^ Help text for this command (including argument description)
                   -> Validator m a  -- ^ Monadic validator (in the "user" monad)
                   -> Handler m a    -- ^ Handling action. Takes the validator output as argument
                   -> 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

-- | A variation of 'param' that allows for "disabling" the command at runtime by
-- running the given "enable" monadic action (as always in the "user" monad) to check
-- if the command should be displayed as an option and/or accepted or not.
param' :: (Monad m) => String         -- ^ Command keyword
                    -> String         -- ^ Help text for this command (including argument description)
                    -> Validator m a  -- ^ Monadic validator (in the "user" monad)
                    -> m Bool         -- ^ Enable action in the "user" monad
                    -> Handler m a    -- ^ Handling action. Takes the validator output as argument
                    -> 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

-- | Create a command using a custom parser, providing thus complete flexibility
custom :: (Monad m) => String      -- ^ Command keyword
                    -> String      -- ^ Help text for this command
                    -> Parser m a  -- ^ Custom parser (runs in the "user" monad)
                    -> m Bool      -- ^ Enable action in the "user" monad
                    -> Handler m a -- ^ Handling action. Takes the validator output as argument
                    -> 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])

-- | A utility action to reset the CLI tree to the root node . Equivalent to @return ToRoot@
top :: (Monad m) => m Action
top :: m Action
top = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
ToRoot

-- | A utility action to "leave" the current CLI level. Equivalent to @return $ LevelUp 1@
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

-- | A utility action to "nest" into a new CLI level. Equivalent to @return NewLevel@
newLevel :: (Monad m) => m Action
newLevel :: m Action
newLevel = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
NewLevel

-- | A utility action to leave the current CLI level untouched. Equivalent to @return NoAction@
noAction :: (Monad m) => m Action
noAction :: m Action
noAction = Action -> m Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
NoAction

-- | A utility parser that reads an input and parses a command label. It can be used as part of
-- custom parsers to first read the command keyword before parsing any arguments etc.
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
(.)

-- | A utility parser that reads an input and parses any of the provided possibilities
-- as a parameter for the command node using this parser (see provided example.hs)
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 }

-- | Launches the CLI application. It doesn't normally return unless an exception is thrown
-- or if it runs out of input in batch mode. Normal return value is that returned by the CommandsT
-- action that built the tree. Remember that 'Settings' is an instance of 'Default'
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 -- I believe it shouldn't actually matter since it will
                                        -- simply be overriden by the last action result but
                                        -- NewLevel als default action is correct in term of the
                                        -- expected behaviour when parsing a command. We keep
                                        -- nesting until done..

  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 -- there must always be at least a root node
                    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