{-# LANGUAGE ImplicitParams, RecordWildCards, TupleSections #-}
-----------------------------------------------------------------------------
{- |
Module: System.Console.StructuredCLI
Description: Application library for building interactive console CLIs
Copyright: (c) Erick Gonzalez, 2017
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:
-- |
-- The following code illustrates a simple but complete
-- CLI app:
--
-- @
-- import Control.Monad.IO.Class (liftIO)
-- import System.Console.StructuredCLI
--
-- root :: Commands ()
-- root = do
--   world >+ do
--     hello
--     bye
--     exit $ Just "return to previous level"
--
-- world :: Commands ()
-- world = command "world" (Just "enter into world") Nothing
--
-- hello :: Commands ()
-- hello = command "hello" (Just "prints a greeting") $ Just $ do
--           liftIO . putStrLn $ "Hello world!"
--           return 0
--
-- bye :: Commands ()
-- bye = command "bye" (Just "say goodbye") $ Just $ do
--         liftIO . putStrLn $ "Sayonara!"
--         return 0
--
-- main :: IO ()
-- main = runCLI "Hello CLI" Nothing root
-- @
--
-- resulting example session:
--
-- >>> Hello CLI > ?
-- - world: enter into world
-- >>> Hello CLI > world
-- >>> Hello CLI world >
-- bye    exit   hello
-- >>> Hello CLI world > hello
-- Hello world!
-- >>> Hello CLI world > exit
--
-- A good way to get you started is to grab the example code available under <https://github.com/erickg/structured-cli/blob/master/example/Main.hs example/Main.hs> and modify it to suit your needs.
                                     Action,
                                     Commands,
                                     CommandsT(..),
                                     Parser,
                                     ParseResult(..),
                                     Settings(..),
                                     State(..),
                                     (>+),
                                     command,
                                     exit,
                                     mkParser,
                                     outputStrLn,
                                     param,
                                     popCommand,
                                     pushCommand,
                                     runCLI,
                                     top) where

import Control.Applicative        (liftA2)
import Control.Exception          (Exception, throw)
import Control.Monad              (foldM, replicateM, void, when)
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, gets, modify)
--import Data.Attoparsec.ByteString (Parser,
--                                   Result,
--                                   parse,
--                                   string)
import Data.Char                  (isSpace)
import Data.Default               (Default, def)
import Data.List                  (filter, isPrefixOf, intercalate, span, sort)
import Data.Monoid                ((<>))
import Data.Typeable              (Typeable)
import System.Console.Haskeline   (Completion,
                                   InputT,
                                   MonadException,
                                   completeWord,
                                   defaultSettings,
                                   getInputLine,
                                   outputStrLn,
                                   runInputT,
                                   setComplete,
                                   simpleCompletion)

import qualified System.Console.Haskeline as Haskeline

data State m = State { nodes  :: [Node m],
                       labels :: [String] }

type CState m = StateT (State m) m
type Action m = CState m Int

data Node m = Node { label    :: String,
                     hint     :: Maybe String,
                     branches :: [Node m],
                     parser   :: Parser m,
                     action   :: Maybe (Action m) }

data Settings = Settings { history :: Maybe FilePath,
                           banner  :: String,
                           prompt  :: String,
                           batch   :: Bool }

data CLIException = Exit deriving (Show, Typeable)

instance Exception CLIException

newtype CommandsT m a = CommandsT { runCommandsT :: m (a, [Node m]) }
type Commands         = CommandsT IO

newtype Parser m = Parser { runParser :: (Bool -> Node m -> String -> m ParseResult) }

data ParseResult = Done String String
                 | Fail String (Maybe String)
                 | Partial
                   deriving Show

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 (Parser m) where
    def = Parser labelParser

instance Default Settings where
    def = Settings Nothing "" " > " False

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

trim :: String -> String
trim = reverse.dropWhile isSpace.reverse

labelParser :: (MonadIO m) => Bool -> Node m -> String -> m ParseResult
labelParser _  Node{..} ""         = return $ Fail ("Missing expected keyword " ++ label) hint
labelParser partial Node{..} input = do
  let (x, remains) = nextWord input
  let result  = if label == x then
                    Done x remains
                else do
                    failure x
  return result
    where failure x | partial   = if x `isPrefixOf` label then Partial else failed
                    | otherwise = failed
          failed                = Fail label hint

noParse :: (Monad m) => Parser m
noParse = Parser . const . const . const . return $ Fail "" Nothing

command :: (MonadIO m) => String -> Maybe String -> Maybe (Action m) -> CommandsT m ()
command name hint action = CommandsT . return . ((),) . pure $ Node name hint [] def action

param :: (Monad m) => String -> Maybe String -> Parser m -> Maybe (Action m) -> CommandsT m ()
param name hint parser action =
    CommandsT . return . ((),) . pure $ Node name hint [] parser action

(>+) :: (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 { branches = ns }])

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

exit :: (MonadIO m) => Maybe String -> CommandsT m ()
exit hint = command "exit" hint $ Just $ do
         ns <- gets nodes
         case ns of
           []  ->
             lostInSpace
           _:[] ->
               lostInSpace
           [_, _] -> do -- only 1 command left in the stack.. (should be root)
               liftIO $ putStrLn "Nowhere else to go. Type <ctrl-C> anytime to exit"
               return 0
           _ ->
               return 1 -- pop 1 command from the stack

top :: (MonadIO m) => Maybe String -> CommandsT m ()
top hint = command "top" hint $ Just $ return (-maxBound)

runCLI :: (MonadException m) => String -> Maybe Settings -> CommandsT m () -> m ()
runCLI name userSettings rootCmds = do
  root     <- execCommandsT rootCmds
  settings <- runMaybeT $ do
               s@Settings{..} <- MaybeT . pure $ userSettings
               when (not batch) $ liftIO . putStrLn $ banner
               return s
  let ?settings = maybe def id settings
  evalStateT loop $ stateFor root
    where stateFor root = State [Node name Nothing root noParse Nothing] [name]
          loop :: (?settings::Settings, MonadException m) => CState m ()
          loop = do
              settings <- getSettings $ history ?settings
              runInputT settings runLevel
              loop

runLevel :: (?settings::Settings, MonadException m) => InputT (CState m) ()
runLevel = do
  prompt  <- if batch ?settings then return "" else lift getPrompt
  nodes0  <- lift $ gets nodes
  labels0 <- lift $ gets labels
  result  <- runMaybeT $ do
              line  <- MaybeT $ getInputLine prompt
              parse line
  case result of
    Nothing -> do
        if batch ?settings then
            throw Exit
        else
            lift $ modify $ \state -> state { nodes = nodes0,    -- parse failed or no action
                                              labels = labels0 } -- restore nodes to previous state
    Just _ -> do
        Node{..} <- lift getCurrentCommand
        case action of
          Nothing -> return ()
          Just x  -> lift $ do
                nodes    <- gets nodes
                popDepth <- x
                let depth  = length nodes
                    depth0 = length nodes0
                    depth' = max 1 $ depth0 - popDepth -- there must always be at least a root node
                    toPop  = depth - depth'
                void $ replicateM toPop popCommand

parse :: (MonadIO m) => String -> MaybeT (InputT (CState m)) [Node m]
parse ""    = currentBranches''
parse ws    | all isSpace ws = currentBranches''
parse input = do
  nodes <- currentBranches''
  (n@Node{..}, matched, remaining) <- findNode input nodes [Nothing]
  lift $ pushCommand' n $ trim matched
  parse remaining

tryParse :: (MonadIO m) => String -> [Node m] -> m [Node m]
tryParse []  (x:_) = return [x]
tryParse _   []    = return []
tryParse " " (x:_) = return $ branches x
tryParse input (n:_) = do
  let nodes = branches n
  result <- findNode' input nodes
  case result of
    Nothing ->
        filterNodes input nodes
    Just (c, remaining) -> do
        tryParse remaining (c:nodes)

filterNodes :: (MonadIO m) => String -> [Node m] -> m [Node m]
filterNodes input = foldM filterNodes' []
    where filterNodes' acc node@Node{..} = do
            result <- runParser parser True node input
            case result of
              Fail _ _ ->
                  return acc
              _ ->
                  return $ node:acc

currentBranches :: (Monad m) => (CState m) [Node m]
currentBranches = getCurrentCommand >>= return . branches

currentBranches'' :: (Monad m,
                      MonadTrans t,
                      MonadTrans u,
                      Monad (u (CState m))) =>
                     t (u (CState m)) [Node m]
currentBranches'' = lift . lift $ currentBranches

findNode :: (MonadIO m) =>
            String ->
           [Node m] ->
           [Maybe ParseResult] ->
           MaybeT (InputT (CState m)) (Node m, String, String)
findNode input [] results = do
  lift $ when (not $ "?" `isPrefixOf` reverse input) $
             outputStrLn $ "Syntax error at or around " ++ input
  let (keyword,_) = nextWord $ reverse $ dropWhile (== '?') $ reverse input
  lift $ mapM_ (outputStrLn.syntaxError) $ filter (matching keyword) results
  MaybeT . return $ Nothing
    where syntaxError (Just (Fail name hint)) = "- " ++ name ++ (maybe "" (": "++) hint)
          syntaxError _ = ""
          matching kw (Just (Fail name _)) = kw `isPrefixOf` name
          matching _ _                    = False
findNode input (node@Node{..}:rest) results = do
  result <- lift . lift .lift $ (runParser parser) False node input
  case result of
    Done matched remaining ->
      return (node, matched, remaining)
    Fail _ _ ->
      findNode input rest $ (Just result):results
    Partial ->
      error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label

findNode' :: (MonadIO m) => String -> [Node m] -> m (Maybe (Node m, String))
findNode' _ []                       = return Nothing
findNode' input (node@Node{..}:rest) = do
  result <- (runParser parser) False node input
  case result of
    Done _ remaining ->
        return $ Just (node, remaining)
    Partial ->
      error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label
    Fail _ _ ->
        findNode' input rest

pushCommand' :: (MonadTrans t, Monad m) => Node m -> String -> t (CState m) ()
pushCommand' n = lift . pushCommand n

pushCommand :: (Monad m) => Node m -> String -> CState m ()
pushCommand n label = do
  ns <- gets nodes
  ls <- gets labels
  modify $ \state -> state { nodes = n:ns, labels = label:ls }

popCommand :: (Monad m) => CState m ()
popCommand = do
  (_:cs) <- gets nodes
  (_:ls) <- gets labels
  modify $ \state -> state { nodes = cs, labels = ls }

getSettings :: (MonadIO m) => Maybe FilePath -> CState m (Haskeline.Settings (CState m))
getSettings path =
    return $ setComplete explorer defaultSettings { Haskeline.historyFile = path }

explorer :: (MonadIO m) => (String, String) -> CState m (String, [Completion])
explorer input@(left, _) = do
  nodes   <- gets nodes
  options <- lift $ getPossibilities left nodes
  let keywords = getLabels options
      complete = completeWord Nothing " " $ \str ->
                   return $ map simpleCompletion $ filter (str `isPrefixOf`) keywords
  r <- complete input
  return r
    where
      getLabels = sort . fmap label

getPossibilities :: (MonadIO m) => String -> [Node m] -> m [Node m]
getPossibilities ""    = return . branches . head
getPossibilities input = tryParse $ reverse input

getCurrentCommand :: (Monad m) => CState m (Node m)
getCurrentCommand = do
  ns <- gets nodes
  case ns of
    [] ->
        lostInSpace
    node:_ ->
        return node

getPrompt :: (?settings::Settings, Monad m) => CState m String
getPrompt = buildPrompt <$> gets labels
    where buildPrompt ns = (intercalate " " . reverse $ ns) ++ prompt ?settings

lostInSpace :: (Monad m) => m a
lostInSpace = error "The impossible has happened: unknown location in CLI"

mkParser :: (MonadIO m) => (Bool -> String -> m ParseResult) -> Parser m
mkParser fun =
    Parser $ \partial node@Node{..} input -> do
      result <- labelParser partial node input
      case result of
        Done matched1 remaining1 -> do
            r <- fun partial remaining1
            return $ case r of
                       Done matched2 remaining2 ->
                           Done (matched1 ++ ' ':matched2) remaining2
                       o ->
                           o
        x ->
            return x