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
|
{-# LANGUAGE FlexibleContexts #-}
module Command
( Cmd(..)
, parseCmd
) where
import Options.Applicative
import Data.Char (isSpace)
import Types
data Cmd = PerformAlt Alteration
| ModifyTip SequenceValue
| OverrideTip SequenceValue
| 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 :: String -> 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' :: [String] -> Cmd
parseCmd' [] = Empty
parseCmd' args = mapResult runParser
where
runParser = execParserPure (prefs $ showHelpOnError) (cmdParser `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"
cmdParser :: Parser Cmd
cmdParser = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
]
|
