summaryrefslogtreecommitdiff
path: root/src/Command.hs
blob: 127e98602dc015ef5f15c650e7efa471baa206f9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
{-# 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