{-# 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,
                                     command',
                                     exit,
                                     mkParser,
                                     outputStrLn,
                                     param,
                                     param',
                                     popCommand,
                                     pushCommand,
                                     runCLI,
                                     top) where

import Control.Applicative        (liftA2)
import Control.Exception          (Exception, throw)
import Control.Monad              (filterM, 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.IORef                 (IORef, readIORef)
import Data.List                  (filter, isPrefixOf, intercalate, span, sort)
import Data.Maybe                 (isJust, fromJust)
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,
                     disable  :: Maybe (IORef Bool),
                     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)
                 | Options String [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 Nothing [] 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 Nothing [] parser action

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

param' :: (Monad m)
         => String
         -> Maybe String
         -> Maybe (IORef Bool)
         -> Parser m
         -> Maybe (Action m)
         -> CommandsT m ()
param' name hint disable parser action =
    CommandsT . return . ((),) . pure $ Node name hint disable [] 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 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 $ branches 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
            disabled <- liftIO $ maybe (return False) readIORef disable
            if disabled
               then return acc
               else do
                 result <- runParser parser True node input
                 case result of
                   Fail _ _ ->
                     return acc
                   Options _ strs -> do
                     let nodes = fakeNode node <$> strs
                     return $ nodes ++ acc
                   _ ->
                     return $ node:acc

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

currentBranches'' :: (MonadIO 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
  disabled <- liftIO $ maybe (return False) readIORef disable
  if disabled
     then findNode input rest results
     else do
       result <- lift . lift .lift $ (runParser parser) False node input
       case result of
         Done matched remaining ->
             return (node, matched, remaining)
         Partial ->
             error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label
         _ ->
             findNode input rest $ (Just result):results

findNode' :: (MonadIO m) => String -> [Node m] -> m (Maybe (Node m, String))
findNode' _ []                       = return Nothing
findNode' input (node@Node{..}:rest) = do
  disabled <- liftIO $ maybe (return False) readIORef disable
  if disabled
     then findNode' input rest
     else do
       result <- (runParser parser) False node input
       case result of
         Done _ remaining ->
           return $ Just (node, remaining)
         Options input' strs -> do
           let nodes = fakeNode node <$> strs
           findNode' input' nodes
         Partial ->
           error $ "Partial match during exact parsing of " ++ input ++ " at or around " ++ label
         _ ->
           findNode' input rest

fakeNode :: (MonadIO m) => Node m -> String -> Node m
fakeNode node str = node { label = str, parser = Parser labelParser }

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 = sort $ fmap label options
  let complete = completeWord Nothing " " $ \str ->
                   return $ map simpleCompletion $ filter (str `isPrefixOf`) keywords
  complete input

getPossibilities :: (MonadIO m) => String -> [Node m] -> m [Node m]
getPossibilities ""    = filterM checkDisabled . branches . head
    where checkDisabled Node{..}
              | isJust disable = do
                  isDisabled <- liftIO $ readIORef (fromJust disable)
                  return $ not isDisabled
              | otherwise = return True
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