From c69563da3ea55820af21edb7cf2af40906630e6e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 8 May 2016 00:40:02 +0200 Subject: command parsing --- src/Command.hs | 76 ++++++++++++++++++++++++++++++++++++---------------------- src/Main.hs | 4 +++- src/Utils.hs | 2 +- 3 files changed, 51 insertions(+), 31 deletions(-) (limited to 'src') 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 , parseCmd ) where -import Data.Set (Set) -import qualified Data.Set as Set +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 (Maybe Comment) @@ -67,44 +74,55 @@ parseCmd = parseCmd' . split parseCmd' :: SequenceM m => [String] -> m Cmd parseCmd' [] = return Empty parseCmd' args = do - knownEntities <- entities - tip <- snd <$> gets getMax + tip <- fmap snd <$> gets MaxPQueue.getMax + 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 - 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" - ] +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 + 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 - entity = Entity <$> + 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 = toMaybe . fmap Text.pack <$> optional (strArgument $ help "Comment to record in history together with this action" <> metavar "COMMENT") + toMaybe (Just t) + | Text.null t = Nothing + | otherwise = Just t + 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 case input of Nothing -> liftIO exitSuccess Just input' -> do - case parseCmd input' of + cmd <- parseCmd input' + case cmd of UnknownCommand help -> do lift . outputStrLn $ help ParseError err -> do @@ -46,5 +47,6 @@ runCli = do Empty -> return () Quit -> liftIO exitSuccess + _ -> undefined 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) apply alteration seq = undefined entities :: MonadState Sequence m => m (Set Entity) -entities = Set.fromList . MaxPQueue.keys <$> get +entities = Set.fromList . MaxPQueue.elems <$> get -- cgit v1.2.3