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
|
{-# 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 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 "dump" $ pure Dump `info` progDesc "Print all internal state in a format not necessarily human readable"
, 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 <$> (Text.pack <$> strArgument (help "Name of the target entity" <> metavar "NAME")) <*> optional (argument positive $ 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
|
