{-# 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              (mapM, replicateM_, void, when)
import Control.Monad.Except       (ExceptT(..), catchError, runExceptT, throwError)
import Control.Monad.IO.Class     (MonadIO, liftIO)
import Control.Monad.Trans        (MonadTrans, lift)
import Control.Monad.Trans.Maybe  (MaybeT(..), runMaybeT)
import Control.Monad.State.Strict (StateT, evalStateT, get, gets, modify, put)
import Data.Char                  (isSpace)
import Data.Default               (Default, def)
import Data.List                  (intercalate, isPrefixOf, sort, span)
import Data.Monoid                ((<>))
import System.Console.Haskeline   (MonadException)

import qualified System.Console.Haskeline as HL

#ifdef __DEBUG__
import Debug.Trace
debugM :: (Applicative f) => String -> f ()
debugM = traceM
#else
debugM :: (Applicative f) => String -> f ()
debugM _ = pure ()
#endif

data State m    = State { stack :: [ Level m ] }

type Level m = ( String, Node m )

type StateM m = StateT (State m) m

type Handler m 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 (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 {
                        getLabel    :: String,
                        getHint     :: String,
                        getBranches :: [Node m],
                        runParser   :: Parser m a,
                        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
      getOutput :: a,
      -- | Part of the string matched during parsing of a command
      getDoneMatched :: String,
      -- | Remaining input data
      getDoneRemaining :: String }
  | Partial {
      -- | List of possible completions along with a corresponding help string
      getPartialHints :: [(String, String)],
      -- | Remaining input data
      getPartialRemaining :: String }
  | Fail {
      -- | A message string containing a possible hint for correct useage
      getFailMessage :: String,
      -- | Remaining input data
      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 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
      getHistory      :: Maybe FilePath,
      -- | Text to display upon start of the CLI application
      getBanner       :: String,
      -- | Prompt characters to display to the right of the current command "stack"
      getPrompt       :: m String,
      -- | Disable prompt for use with batch scripts
      isBatch         :: Bool,
      -- | Exception handler
      handleException :: ExceptionHandler m }

data CLIException = Exit
                  | InternalError String
                  | SyntaxError String String
                  | UndecisiveInput String [String]
                  | HelpRequested [(String, String)]
                  | InvalidOperation String
                    deriving 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 { 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 f = CommandsT . fmap (\(a, w) -> (f a, w)) . runCommandsT

instance (Applicative a) => Applicative (CommandsT a) where
    pure    = CommandsT . pure . (, mempty)
    x <*> y = CommandsT $ liftA2 f (runCommandsT x) (runCommandsT y)
        where f (a, v) (b, w) = (a b, v <> w)

instance (Monad m) => Monad (CommandsT m) where
    return = pure
    m >>= f  = CommandsT $ do
               (a, v)  <- runCommandsT m
               (b, w) <- runCommandsT $ f a
               return $ (b, v <> w)
    fail msg = CommandsT $ fail msg

instance MonadTrans CommandsT where
    lift m = CommandsT $ do
               a <- m
               return (a, mempty)

instance (MonadIO m) => MonadIO (CommandsT m) where
    liftIO = lift . liftIO

instance (MonadIO m) => Default (Settings m) where
    def = Settings Nothing "" (return " > ") False defExceptionHandler

instance (Monad m) => Default (Parser m String) where
    def = labelParser

instance (Monad m) => Default (Validator m String) where
    def = return . pure

type ParserT m = ExceptT CLIException (HL.InputT (StateM m))

liftStateM :: (Monad m) => StateM m a -> ParserT m a
liftStateM = lift . lift

liftInputT :: (Monad m) => HL.InputT (StateM m) a -> ParserT m a
liftInputT = lift

liftUserM :: (Monad m) => m a -> ParserT m a
liftUserM = lift . lift . lift

execCommandsT :: (Monad m) => CommandsT m a -> m [Node m]
execCommandsT  = fmap snd . runCommandsT

data SearchResult m = Completed { completedNode      :: Node m,
                                  completedAction    :: m Action,
                                  completedMatched   :: String,
                                  completedRemaining :: String }
                    | Incomplete { incompleteNode    :: Node m,
                                   incompleteHints   :: [(String, String)] }
                    | Failed { failedNode :: Node m,
                               failedMsg :: String,
                               failedRemaining :: String }
                    | NoResult

isCompleted :: (Monad m) => SearchResult m -> Bool
isCompleted Completed{..} = True
isCompleted _             = False

isIncomplete :: (Monad m) => SearchResult m -> Bool
isIncomplete Incomplete{..} = True
isIncomplete _              = False

isNoResult :: (Monad m) => SearchResult m -> Bool
isNoResult NoResult = True
isNoResult _        = False

isFailed :: (Monad m) => SearchResult m -> Bool
isFailed Failed{..} = True
isFailed _          = 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 ()
node >+ descendents = do
  node' <- lift $ execCommandsT node
  case node' of
    [] ->
        error $ "Cannot branch off empty command"
    _:_:_ ->
        error $ "Cannot branch off more than one command"
    [predecessor] ->
        CommandsT $ do
               ns <- execCommandsT descendents
               return ((), [predecessor { getBranches = ns }])

-- | 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 label hint action = do
  command' label hint (return True) 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' label hint enable action = do
  custom label hint labelParser enable $ const 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 label hint validator handler =
    param' label hint validator (return True) 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' label hint validator enable handler = do
  custom label hint parser enable handler
         where parser = paramParser hint 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 label hint parser enable handler = do
  let node = Node { getLabel    = label,
                    getHint     = hint,
                    getBranches = [],
                    runParser   = parser,
                    isEnabled   = enable,
                    handle      = handler }
  CommandsT . return $ ((), [node])

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

-- | A utility action to "leave" the current CLI level. Equivalent to @return $ LevelUp 1@
exit :: (Monad m) => m Action
exit = return $ LevelUp 1

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

-- | A utility action to leave the current CLI level untouched. Equivalent to @return NoAction@
noAction :: (Monad m) => m Action
noAction = return 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{..} input = do
    case nextWord input of
      ("?", remaining) ->
        return $ Fail getHint remaining
      (word, remaining) | word == getLabel ->
        return $ Done "" word remaining
      (word, remaining) | word `isPrefixOf` getLabel ->
        return $ Partial [(getLabel, getHint)] remaining
      (_, _) ->
        return $ NoMatch

infixr 9 -.-
(-.-) :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
(-.-) = (.).(.)

-- | 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 possibilities hint = parseOneOf' -.- labelParser
    where parseOneOf' = (=<<) parseOneOf''
          parseOneOf'' :: (Monad m) => ParseResult String -> m (ParseResult String)
          parseOneOf'' (Done _ _ rest) =
              case nextWord rest of
                ("?", _) ->
                    return $ Fail hint rest
                ("", remaining) ->
                    return $ Partial (zip possibilities $ repeat "") remaining
                (word, _) -> do
                  results <- mapM (parseOne word) (zip possibilities $ repeat "")
                  case filter isDone results of
                    (Done _ matched remaining:_) -> return $ Done matched matched remaining
                    _          ->
                      case filter isPartial results of
                        []       ->
                          case results of
                            (result':_) -> return result'
                            _           -> return NoMatch
                        partials ->
                          return $ foldl merge (Partial [] "") partials
          parseOneOf'' (Fail hint' rest) = return $ Fail hint' rest
          parseOneOf'' (Partial xs rest) = return $ Partial xs rest
          parseOneOf'' NoMatch           = return NoMatch
          merge (Partial ps _) (Partial ps' rest') = Partial (ps ++ ps') rest'
          merge _  _ = error "Internal inconsistency merging partial results from parseOneOf"
          isDone (Done _ _ _)     = True
          isDone _                = False
          isPartial (Partial _ _) = True
          isPartial _             = False
          parseOne input (str, hint') = labelParser Node { getLabel    = str,
                                                           getHint     = hint',
                                                           getBranches = [],
                                                           isEnabled   = return True,
                                                           runParser   = error "dummy parser",
                                                           handle      = const $ return NoAction
                                                         } input

paramParser :: Monad m => String -> (String -> m (Maybe a)) -> Node m -> String -> m (ParseResult a)
paramParser hint validator = parseParam -.- labelParser
    where parseParam  = (=<<) parseParam'
          parseParam' (Done _ matched rest) =
              case nextWord rest of
                ("?", _) ->
                  return $ Fail hint rest
                ("", remaining) ->
                  return $ Partial [("", hint)] remaining
                (word, remaining) -> do
                  v <- validator word
                  return $ maybe (badArg rest) (\x -> Done x (matched ++ ' ':word) remaining) v
          parseParam' (Fail x y) =
              return $ Fail x y
          parseParam' (Partial x y) =
              return $ Partial x y
          parseParam' NoMatch = return NoMatch
          badArg = Fail hint

nextWord :: String -> (String, String)
nextWord = span (not.isSpace) . dropWhile isSpace

hLineSettingsFrom :: (MonadIO m) => Settings m -> HL.Settings (StateM m)
hLineSettingsFrom Settings{..} =
    HL.setComplete explorer HL.defaultSettings { HL.historyFile = getHistory }

-- | 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 :: (MonadException m) => String -> Settings m -> CommandsT m a -> m (Either CLIException a)
runCLI name settings@Settings{..} commands = do
  (value, root) <- runCommandsT commands
  when (not isBatch) $ liftIO . putStrLn $ getBanner
  let ?settings = settings
  withStateM root . HL.runInputT hLineSettings . runExceptT $ do
    loop
    return value
    where hLineSettings      = hLineSettingsFrom settings
          withStateM root    = flip evalStateT $ state0 root
          processInput       = do
            let ?settings = settings
            state <- liftStateM get
            runLevel `catchError` \e -> do
                liftStateM $ put state
                throwError e
            processInput
          dummyParser _ = \_ input ->
            return $ Partial [] input
          state0 root        = State [(name, mkNode root)]
          mkNode root = Node {
                          getLabel    = name,
                          getHint     = mempty,
                          getBranches = root,
                          runParser   = dummyParser root,
                          isEnabled   = return True,
                          handle      = const . return $ NewLevel
                        }
          loop =  do
            void . catchError processInput $
                                  \e -> do
                                    exceptionResult <- liftUserM $ handleException e
                                    either throwError return exceptionResult
                                    loop

defExceptionHandler :: (MonadIO m) => CLIException -> m (Either CLIException ())
defExceptionHandler (SyntaxError str msg) = do
    fmap Right . liftIO . putStrLn $ "SyntaxError at or around " ++ str ++ ": " ++ msg ++ "\n"
defExceptionHandler (HelpRequested hints) =
    fmap Right . liftIO $ do
      mapM_ display $ hints
      putStrLn ""
        where display (label, hint) =
                  putStrLn $ "- " ++ label ++ ": " ++ hint
defExceptionHandler e =
    return . Left $ e

runLevel :: (?settings::Settings m, MonadException m) => ParserT m ()
runLevel = do
  prompt  <- liftUserM . buildPrompt =<< withLabels
  stack0  <- getStack
  result  <- runMaybeT $ do
              line  <- MaybeT . liftInputT $ HL.getInputLine prompt
              process line
  case result of
    Nothing ->
      if isBatch ?settings
         then throwError Exit
         else restore stack0
    _ ->
      return ()

    where buildPrompt ns = (showStack ns ++) <$> getPrompt ?settings
          withLabels     = fmap fst <$> getStack
          restore stack  = liftStateM . modify $ \s -> s { stack = stack }
          showStack      = intercalate " " . reverse

getStack :: (Monad m) => ParserT m [Level m]
getStack = liftStateM $ gets stack

process :: (Monad m) => String -> MaybeT (ParserT m) ()
process input = lift $ do
  stack0 <- getStack
  node <- getCurrentNode
  action <- process' input node NewLevel -- 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 of
    NewLevel ->
        return ()
    LevelUp n ->
        levelUp n stack0
    NoAction ->
        levelUp 0 stack0
    ToRoot ->
        levelUp (-maxBound) stack0
    where levelUp levels stack0 = do
                stack <- getStack
                let depth  = length stack
                    depth0 = length stack0
                    depth' = max 1 $ depth0 - levels -- there must always be at least a root node
                    to     = depth - depth'
                replicateM_ to pop

process' :: (Monad m) => String -> Node m -> Action ->  ParserT m Action
process' "" _ action =
    return action
process' (' ':remaining) node action =
    process' remaining node action
process' input currentNode _ = do
  debugM $ "processing " ++ show input ++ " on " ++ getLabel currentNode
  result <- liftStateM $ findNext currentNode input
  case result of
    [Completed{ completedNode=node@Node{..}, ..}] -> do
      push completedMatched node
      action <- liftUserM completedAction
      process' completedRemaining node action
    _ ->
      if checkForHelp . dropWhile isSpace $ reverse input then do
          let hints = foldl getHelp [] result
          debugM $ "help requested: " ++ show hints
          throwError . HelpRequested $ hints
      else
          case filter isFailed result of
            Failed{..}:_ ->
                throwError . SyntaxError input $ failedMsg
            _ ->
                case filter isIncomplete result of
                  Incomplete{..}:_ ->
                      throwError . SyntaxError input . snd . head $ incompleteHints
                  _ ->
                      throwError . SyntaxError input $ ""

    where checkForHelp ('?':_)       = True
          checkForHelp _             = False
          getHelp acc Failed{..}     = (getLabel failedNode, failedMsg):acc
          getHelp acc Incomplete{..} = incompleteHints ++ acc
          getHelp acc Completed{..}  = help completedNode : acc
          getHelp acc _              = acc

help :: (Monad m) => Node m -> (String , String)
help Node{..} = (getLabel, getHint)

push :: (Monad m) => String -> Node m -> ParserT m ()
push label node =
  liftStateM . modify $ \s@State{..} ->
      s { stack = (label, node) : stack }

pop :: (Monad m) => ParserT m ()
pop = do
  stack <- liftStateM $ gets stack
  case stack of
    (_:remaining) ->
        liftStateM $ modify $ \s -> s { stack = remaining }
    [] ->
        throwError . InvalidOperation $ "Invalid attempt to pop element from empty command stack"

getCurrentNode :: (Monad m) => ParserT m (Node m)
getCurrentNode = do
  stack <- liftStateM $ gets stack
  case stack of
    ((_, node):_) -> return node
    []            -> throwError . InternalError $ "Empty command stack"

findNext :: (Monad m) => Node m -> String -> StateM m [SearchResult m]
findNext root input = do
  filter (not . isNoResult) <$> mapM matching branches
      where matching node@Node{..} = do
              enabled <- lift isEnabled
              if enabled then do
                  result <- lift $ runParser node input
                  case result of
                    Done output matched rest ->
                        return Completed { completedNode      = node,
                                           completedAction    = handle output,
                                           completedMatched   = matched,
                                           completedRemaining = rest }
                    Fail msg rest ->
                        return Failed { failedNode = node,
                                        failedMsg  = msg,
                                        failedRemaining = rest }
                    Partial hints _ ->
                        return Incomplete { incompleteNode  = node,
                                            incompleteHints = hints }
                    NoMatch ->
                        return NoResult
              else
                  return NoResult
            branches = getBranches root

explorer :: (Monad m) => HL.CompletionFunc (StateM m)
explorer input@(tfel, _) = do
  currentLevel  <- gets stack
  possibilities <- case currentLevel of
                    (_, currentNode):_ ->
                        sort <$> getPossibilities currentNode left
                    _ ->
                        return []
  let complete = HL.completeWord Nothing " " $ \str ->
                   return $ map HL.simpleCompletion $ filter (str `isPrefixOf`) possibilities
  complete input
      where left = reverse tfel

getPossibilities :: (Monad m) => Node m -> String -> StateM m [String]
getPossibilities root input = do
  results <- findNext root input
  case filter isCompleted results of
    (_:_:_) ->
      return []
    Completed{..}:[] ->
      getPossibilities completedNode completedRemaining
    _ ->
      return $ fst <$> foldl getPossibilities' [] results
    where getPossibilities' acc Incomplete{..} = filter notEmpty incompleteHints ++ acc
          getPossibilities' acc _              = acc
          notEmpty ("", _) = False
          notEmpty (_, _)  = True