{-# 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.
                                     Commands,
                                     CommandsT(..),
                                     Parser,
                                     ParseResult(..),
                                     Settings(..),
                                     (>+),
                                     command,
                                     exit,
                                     mkParser,
                                     outputStrLn,
                                     param,
                                     popCommand,
                                     pushCommand,
                                     runCLI,
                                     top) where

import Control.Applicative        (liftA2)
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 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 }

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

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

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
               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  <- lift getPrompt
  nodes0  <- lift $ gets nodes
  labels0 <- lift $ gets labels
  result  <- runMaybeT $ do
              line  <- MaybeT $ getInputLine prompt
              parse line
  case result of
    Nothing -> do
        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
    Just _ -> do
        return ()

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