summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Command.hs76
-rw-r--r--src/Main.hs4
-rw-r--r--src/Utils.hs2
3 files changed, 51 insertions, 31 deletions
diff --git a/src/Command.hs b/src/Command.hs
index 79893a5..3616729 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -5,13 +5,20 @@ module Command
5 , parseCmd 5 , parseCmd
6 ) where 6 ) where
7 7
8import Data.Set (Set) 8import Data.PQueue.Prio.Max (MaxPQueue)
9import qualified Data.Set as Set 9import qualified Data.PQueue.Prio.Max as MaxPQueue (getMax)
10
11import Control.Monad.State (MonadState(..), gets)
10 12
11import Options.Applicative 13import Options.Applicative
12 14
13import Data.Char (isSpace) 15import Data.Char (isSpace)
14 16
17import Data.Text (Text)
18import qualified Data.Text as Text
19
20import Data.Maybe (fromMaybe)
21
15import Types 22import Types
16 23
17data Cmd = PerformAlt Alteration (Maybe Comment) 24data Cmd = PerformAlt Alteration (Maybe Comment)
@@ -67,44 +74,55 @@ parseCmd = parseCmd' . split
67parseCmd' :: SequenceM m => [String] -> m Cmd 74parseCmd' :: SequenceM m => [String] -> m Cmd
68parseCmd' [] = return Empty 75parseCmd' [] = return Empty
69parseCmd' args = do 76parseCmd' args = do
70 knownEntities <- entities 77 tip <- fmap snd <$> gets MaxPQueue.getMax
71 tip <- snd <$> gets getMax 78 let
79 runParser = execParserPure (prefs $ showHelpOnError) (cmdParser tip `info` progDesc "sequence - A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)") args
72 return $ mapResult runParser 80 return $ mapResult runParser
73 where 81 where
74 runParser = execParserPure (prefs $ showHelpOnError) (cmdParser knownEntities tip `info` progDesc "sequence - A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)") args
75 mapResult (Success a) = a 82 mapResult (Success a) = a
76 mapResult (Failure help) = UnknownCommand . fst $ renderFailure help "" 83 mapResult (Failure help) = UnknownCommand . fst $ renderFailure help ""
77 mapResult (CompletionInvoked _ ) = ParseError "Completion triggered" 84 mapResult (CompletionInvoked _ ) = ParseError "Completion triggered"
78 85
79-- data Cmd = PerformAlt Alteration (Maybe Comment) 86cmdParser :: Maybe Entity -> Parser Cmd
80-- | ShowTip 87cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
81-- | ShowHistory (Maybe Integer) 88 , command "dump" $ pure Dump `info` progDesc "Print all internal state in a format not necessarily human readable"
82-- | Dump 89 , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history"
83-- | Quit 90 , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?"
84-- data Alteration = Modify Entity SequenceValue 91 , command "set" $ parseOverride `info` progDesc "Set an entities sequence value"
85-- | Override Entity SequenceValue 92 , command "modify" $ parseModify `info` progDesc "Modify an entities sequence value"
86-- | Drop Entity 93 , command "drop" $ parseDrop `info` progDesc "Stop tracking an entity"
87-- | Insert Entity SequenceValue 94 , command "add" $ parseAdd `info` progDesc "Start tracking an entity"
88-- | Rename Entity Entity 95 , command "rename" $ parseRename `info` progDesc "Rename an entity"
89 96 ]
90cmdParser :: Set Entity -> Entity -> Parser Cmd
91cmdParser knownEntities tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
92 , command "dump" $ pure Dump `info` progDesc "Print all internal state in a format not necessarily human readable"
93 , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history"
94 , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?"
95 , command "set" $ parseOverride `info` progDesc "Set an entities sequence value"
96 , command "modify" $ parseModify `info` progDesc "Modify an entities sequence value"
97 , command "drop" $ parseDrop `info` progDesc "Stop tracking an entity"
98 , command "add" $ parseAdd `info` progDesc "Start tracking an entity"
99 , command "rename" $ parseRename `info` progDesc "Rename an entity"
100 ]
101 where 97 where
102 parseHistory = ShowHistory <$> optional (argument natural (help "How many entries to display" <> metavar "NATURAL")) 98 parseHistory = ShowHistory <$> optional (argument natural (help "How many entries to display" <> metavar "NATURAL"))
103 parseOverride = PerformAlt <$> (Override <$> entity <*> sequenceValue) <*> comment 99 parseOverride = PerformAlt <$> (Override <$> entity <*> sequenceValue') <*> comment
100 parseModify = PerformAlt <$> (Modify <$> entity <*> sequenceValue) <*> comment
101 parseDrop = PerformAlt <$> (Drop <$> entity) <*> comment
102 parseAdd = PerformAlt <$> (Insert <$> entity <*> sequenceValue') <*> comment
103 parseRename = PerformAlt <$> (Rename <$> entity <*> entity') <*> comment
104 104
105 natural = do 105 natural = do
106 int <- auto 106 int <- auto
107 if int < 0 107 if int < 0
108 then readerError "Natural number (0 ≤ n) required" 108 then readerError "Natural number (0 ≤ n) required"
109 else return int 109 else return int
110 entity = Entity <$> 110 positive = do
111 int <- auto
112 if int <= 0
113 then readerError "Positive number (0 < n) required"
114 else return int
115
116 entity
117 | (Just tip') <- tip = fromMaybe tip' <$> optional entity'
118 | otherwise = entity'
119 entity' = Entity <$> (Text.pack <$> strArgument (help "Name of the target entity" <> metavar "NAME")) <*> optional (argument positive $ help "Number of the target entity" <> metavar "NUMBER")
120
121 sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE")
122 sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE")
123
124 comment = toMaybe . fmap Text.pack <$> optional (strArgument $ help "Comment to record in history together with this action" <> metavar "COMMENT")
125 toMaybe (Just t)
126 | Text.null t = Nothing
127 | otherwise = Just t
128 toMaybe Nothing = Nothing
diff --git a/src/Main.hs b/src/Main.hs
index 0088b7c..c3c1d7e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -38,7 +38,8 @@ runCli = do
38 case input of 38 case input of
39 Nothing -> liftIO exitSuccess 39 Nothing -> liftIO exitSuccess
40 Just input' -> do 40 Just input' -> do
41 case parseCmd input' of 41 cmd <- parseCmd input'
42 case cmd of
42 UnknownCommand help -> do 43 UnknownCommand help -> do
43 lift . outputStrLn $ help 44 lift . outputStrLn $ help
44 ParseError err -> do 45 ParseError err -> do
@@ -46,5 +47,6 @@ runCli = do
46 Empty -> return () 47 Empty -> return ()
47 48
48 Quit -> liftIO exitSuccess 49 Quit -> liftIO exitSuccess
50
49 _ -> undefined 51 _ -> undefined
50 runCli 52 runCli
diff --git a/src/Utils.hs b/src/Utils.hs
index 945c6b7..6c8f0c1 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -37,4 +37,4 @@ apply :: Alteration -> Sequence -> (Sequence, History)
37apply alteration seq = undefined 37apply alteration seq = undefined
38 38
39entities :: MonadState Sequence m => m (Set Entity) 39entities :: MonadState Sequence m => m (Set Entity)
40entities = Set.fromList . MaxPQueue.keys <$> get 40entities = Set.fromList . MaxPQueue.elems <$> get