{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}

module Command
       ( Cmd(..)
       , parseCmd
       ) where

import Data.PQueue.Prio.Max (MaxPQueue)
import qualified Data.PQueue.Prio.Max as MaxPQueue (getMax)
  
import Control.Monad.State (MonadState(..), gets)

import Options.Applicative

import Data.Char (isSpace)

import Data.Text (Text)
import qualified Data.Text as Text

import Data.Maybe (fromMaybe)

import           Data.CaseInsensitive  ( CI )
import qualified Data.CaseInsensitive as CI
  
import Types

data Cmd = PerformAlt Alteration Comment
         | ShowTip
         | ShowHistory (Maybe Integer)
         | Dump
         | Quit
         | UnknownCommand String
         | ParseError String
         | Empty

quoteChars, escapeChars :: [Char]
quoteChars = ['"', '\'']
escapeChars = ['\\']

isQuote, isEscape :: Char -> Bool
isQuote q = q `elem` quoteChars
isEscape e = e `elem` escapeChars

parseCmd :: SequenceM m => String -> m Cmd
parseCmd = parseCmd' . split
  where
    split :: String -> [String]
    split = reverse . split' [] "" Nothing Nothing
    split' :: [String] -> String -> Maybe Char -> Maybe Char -> String -> [String]
    split' ws w q e "" = trimStart $ (prepend q . append e $ reverse w):ws
      where
        prepend (Just c) = (c : )
        prepend _ = id
        append (Just c) = (++ [c])
        append _ = id
        trimStart ("":ws) = ws
        trimStart ws = ws
    split' ws w q e (c:cs)
      | null w
      , Nothing <- q
      , Nothing <- e
      , isQuote c           = split' ws w (Just c) Nothing cs -- Start quoted word at unescaped quote
      | Nothing <- e
      , (Just q') <- q
      , c == q'             = split' (reverse w : ws) "" Nothing Nothing cs -- Close quoted word at unescaped quote of same type
      | null w
      , isSpace c
      , Nothing <- e
      , Nothing <- q        = split' ws w Nothing Nothing cs -- Ignore leading unescaped spaces if not within quotes
      | isSpace c
      , Nothing <- e
      , Nothing <- q        = split' (reverse w : ws) "" Nothing Nothing cs -- Close unquoted word at unescaped space
      | Nothing <- e
      , isEscape c          = split' ws w q (Just c) cs -- Set escaped flag at unescaped escape char
      | otherwise           = split' ws (c : w) q Nothing cs -- Append to word

parseCmd' :: SequenceM m => [String] -> m Cmd
parseCmd' [] = return Empty
parseCmd' args = do
  tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence)
  let
    runParser = execParserPure (prefs $ showHelpOnError) (cmdParser tip `info` progDesc "sequence - A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)") args
  return $ mapResult runParser
  where
    mapResult (Success a) = a
    mapResult (Failure help) = UnknownCommand . fst $ renderFailure help ""
    mapResult (CompletionInvoked _ ) = ParseError "Completion triggered" 

cmdParser :: Maybe Entity -> Parser Cmd
cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
                                     , command "list" $ pure Dump `info` progDesc "Print a list of tracked entities"
                                     , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history"
                                     , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?"
                                     , command "set" $ parseOverride `info` progDesc "Set an entities sequence value"
                                     , command "modify" $ parseModify `info` progDesc "Modify an entities sequence value"
                                     , command "drop" $ parseDrop `info` progDesc "Stop tracking an entity"
                                     , command "add" $ parseAdd `info` progDesc "Start tracking an entity"
                                     , command "rename" $ parseRename `info` progDesc "Rename an entity"
                                     ]
  where
    parseHistory = ShowHistory <$> optional (argument natural (help "How many entries to display" <> metavar "NATURAL"))
    parseOverride = PerformAlt <$> (Override <$> entity <*> sequenceValue') <*> comment
    parseModify = PerformAlt <$> (Modify <$> entity <*> sequenceValue) <*> comment
    parseDrop = PerformAlt <$> (Drop <$> entity) <*> comment
    parseAdd = PerformAlt <$> (Insert <$> entity <*> sequenceValue') <*> comment
    parseRename = PerformAlt <$> (Rename <$> entity <*> entity') <*> comment

    natural = do
      int <- auto
      if int < 0
        then readerError "Natural number (0 ≤ n) required"
        else return int
    positive = do
      int <- auto
      if int <= 0
        then readerError "Positive number (0 < n) required"
        else return int

    entity
      | (Just tip') <- tip = fromMaybe tip' <$> optional entity'
      | otherwise = entity'
    entity' = Entity <$> (CI.mk . Text.pack <$> strArgument (help "Name of the target entity" <> metavar "NAME")) <*> optional (option positive $ long "number" <> short 'n' <> help "Number of the target entity" <> metavar "NUMBER")

    sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE")
    sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE")

    comment = fromMaybe "" . fmap Text.pack <$> optional (strArgument $ help "Comment to record in history together with this action" <> metavar "COMMENT")
    toMaybe Nothing = Nothing