{-# LANGUAGE ImplicitParams,
             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,
                                     Parser,
                                     ParseResult(..),
                                     Settings(..),
                                     Validator,
                                     (>+),
                                     command,
                                     command',
                                     exit,
                                     newLevel,
                                     noAction,
                                     param,
                                     param',
                                     runCLI,
                                     top) where

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

import qualified System.Console.Haskeline as HL

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

type Level m = ( String, Node m )

type StateM m = StateT (State m) m

type Handler m  = String -> m Action

-- | 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)

data Node m = Node { getLabel    :: String,
                     getHint     :: String,
                     getBranches :: [Node m],
                     runParser   :: Parser m,
                     isEnabled   :: m Bool,
                     handle      :: Handler m }

type Parser m = Node m -> String -> m ParseResult

-- | 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 = String -> m (Maybe String)

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 =
    Done {
      -- | Output string to be fed to the command action handler
      getOutput :: String,
      -- | Part of the string matched during parsing of a command
      getDoneMatched :: String,
      -- | Remaining input data
      getDoneRemaining :: String }
  | Partial {
      -- | List of possible completions after given input for this command
      getCompletions :: [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       :: String,
      -- | Disable prompt for use with batch scripts
      isBatch         :: Bool,
      -- | Exception handler
      handleException :: ExceptionHandler m }

data CLIException = Exit
                  | InternalError String
                  | SyntaxError 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 "" " > " False defExceptionHandler

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

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

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

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

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

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

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

-- | 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
  let node = Node { getLabel    = label,
                    getHint     = hint,
                    getBranches = [],
                    runParser   = labelParser,
                    isEnabled   = enable,
                    handle      = const action }
  CommandsT . return $ ((), [node])

-- | 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 string
-- 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  -- ^ Monadic validator (in the "user" monad)
                   -> Handler m    -- ^ Action in the "user" monad (i.e. @return NewLevel@)
                   -> 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  -- ^ Monadic validator (in the "user" monad)
                    -> m Bool       -- ^ Enable action in the "user" monad
                    -> Handler m    -- ^ Action in the "user" monad (i.e. @return NewLevel@)
                    -> CommandsT m ()
param' label hint validator enable handler = do
  let node = Node { getLabel    = label,
                    getHint     = hint,
                    getBranches = [],
                    runParser   = paramParser hint validator,
                    isEnabled   = enable,
                    handle      = handler }
  CommandsT . return $ ((), [node])

-- | 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

labelParser :: (Monad m) => Node m -> String -> m ParseResult
labelParser Node{..} input = do
    case nextWord input of
      (word, remaining) | word == getLabel ->
        return $ Done "" word remaining
      (word, remaining) | word `isPrefixOf` getLabel ->
        return $ Partial [getLabel] remaining
      (_, _) ->
        return $ NoMatch

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

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

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

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

-- | 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' _ t   = return . (flip Partial) t . fmap getLabel
          dummyParser  r s t = dummyParser' s t r
          state0 root        = State [(name, mkNode root)]
          mkNode root = Node {
                          getLabel    = name,
                          getHint     = mempty,
                          getBranches = root,
                          runParser   = dummyParser root,
                          isEnabled   = return True,
                          handle      = const . return $ NewLevel
                        }
          loop =  do
            void . catchError processInput $
                                  \e -> do
                                    exceptionResult <- liftUserM $ handleException e
                                    either throwError return exceptionResult
                                    loop

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

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

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

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

process :: (Monad m) => String -> MaybeT (ParserT m) ()
process input = lift $ do
  stack0 <- getStack
  node <- getCurrentNode
  action <- process' input node NewLevel -- 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
  result <- liftStateM $ findNext currentNode input
  case result of
    ([], _, _, _) ->
      throwError . SyntaxError $ input
    ([node@Node{..}], output, matched, remaining) -> do
      checkForHelp matched [node]
      push matched node
      action <- liftUserM $ handle output
      process' remaining node action
    (nodes, _, matched, _) ->  do
      checkForHelp matched nodes
      throwError . UndecisiveInput input $ fmap getLabel nodes
    where checkForHelp "?" nodes =
              void . throwError . HelpRequested $ fmap help nodes
          checkForHelp _ _ =
              return ()

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

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

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

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

findNext :: (Monad m) => Node m -> String -> StateM m ([Node m], String, String, String)
findNext = findNext' False

findAll :: (Monad m) => Node m -> String -> StateM m ([Node m], String, String, String)
findAll = findNext' True

findNext' :: (Monad m) => Bool -> Node m -> String -> StateM m ([Node m], String, String, String)
findNext' wantsPartial root input = do
  (nodes, output, matched, remaining, _isDone) <- foldM matching ([], "", "", input, False) branches
  return (nodes, output, matched, remaining)
      where matching acc@(nodes, "", _, remaining, False) node@Node{..} = do
              enabled <- lift isEnabled
              if enabled then
                  case nextWord remaining of
                    (q@"?", _) ->
                      return (node:nodes, "", q, remaining, False)
                    _ -> do
                      result <- lift $ runParser node remaining
                      case result of
                        Done output matched rest ->
                          return ([node], output, matched, rest, True)
                        Fail _ rest ->
                          case nextWord rest of
                            (q@"?", _) ->
                              return ([node], "", q, rest, True)
                            _ ->
                              return acc
                        Partial _ remaining' ->
                            if wantsPartial
                              then return (node:nodes, "", "", remaining', False)
                              else return acc
                        NoMatch ->
                          return acc
              else
                  return acc
            matching acc _ = return acc -- short circuit out of the fold if output is not empty
            branches       = getBranches root

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

getPossibilities :: (Monad m) => Node m -> String -> StateM m [String]
getPossibilities root input = do
  result <- findAll root input
  case result of
    ([node], _, _, "") -> do
        result' <- lift $ runParser root node input
        case result' of
          Done _ _ _ ->
            return [" "] -- perfect match - complete with space
          Partial possibilities _ ->
            return possibilities
          _ ->
            return []
    ([node], _, _, remaining) ->
      getPossibilities node remaining
    ([], _, _, _) ->
      return []
    (nodes, _, _, _) -> do
      concat <$> mapM getPossibility nodes
        where getPossibility node@Node{..} = do
                result' <- lift $ runParser node input
                case result' of
                  Partial matches _ ->
                      return matches
                  _ ->
                      return []