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
|
{-# LANGUAGE FlexibleContexts #-}
module Command
( Cmd(..)
, parseCmd
) where
import Data.Set (Set)
import qualified Data.Set as Set
import Options.Applicative
import Data.Char (isSpace)
import Types
data Cmd = PerformAlt Alteration (Maybe 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
knownEntities <- entities
tip <- snd <$> gets getMax
return $ mapResult runParser
where
runParser = execParserPure (prefs $ showHelpOnError) (cmdParser knownEntities tip `info` progDesc "sequence - A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)") args
mapResult (Success a) = a
mapResult (Failure help) = UnknownCommand . fst $ renderFailure help ""
mapResult (CompletionInvoked _ ) = ParseError "Completion triggered"
-- data Cmd = PerformAlt Alteration (Maybe Comment)
-- | ShowTip
-- | ShowHistory (Maybe Integer)
-- | Dump
-- | Quit
-- data Alteration = Modify Entity SequenceValue
-- | Override Entity SequenceValue
-- | Drop Entity
-- | Insert Entity SequenceValue
-- | Rename Entity Entity
cmdParser :: Set Entity -> Entity -> Parser Cmd
cmdParser knownEntities 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
natural = do
int <- auto
if int < 0
then readerError "Natural number (0 ≤ n) required"
else return int
entity = Entity <$>
|
