From 6ce5de5a227267e359aa3c38344e3858f035287d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 8 May 2016 01:05:00 +0200 Subject: command interpretation --- src/Command.hs | 11 ++++------- src/Main.hs | 38 +++++++++++++++++++++++++++----------- src/Types.hs | 17 ++++++++++++++--- src/Utils.hs | 23 ++++++++++++++++------- 4 files changed, 61 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/Command.hs b/src/Command.hs index 3616729..659d14d 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} module Command ( Cmd(..) @@ -21,7 +21,7 @@ import Data.Maybe (fromMaybe) import Types -data Cmd = PerformAlt Alteration (Maybe Comment) +data Cmd = PerformAlt Alteration Comment | ShowTip | ShowHistory (Maybe Integer) | Dump @@ -74,7 +74,7 @@ parseCmd = parseCmd' . split parseCmd' :: SequenceM m => [String] -> m Cmd parseCmd' [] = return Empty parseCmd' args = do - tip <- fmap snd <$> gets MaxPQueue.getMax + 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 @@ -121,8 +121,5 @@ cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDes 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 + comment = fromMaybe "" . fmap Text.pack <$> optional (strArgument $ help "Comment to record in history together with this action" <> metavar "COMMENT") toMaybe Nothing = Nothing diff --git a/src/Main.hs b/src/Main.hs index c3c1d7e..86c8771 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,6 +6,9 @@ import qualified Data.PQueue.Prio.Max as MaxPQueue import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..)) import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as Text + import Data.Default.Class import Data.Maybe (fromMaybe) @@ -23,30 +26,43 @@ import Types import Utils import Command -type SequenceT m a = WriterT History (InputT (StateT Sequence m)) a - main :: IO () main = do historyFile <- flip getUserCacheFile "history" =<< getProgName let settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings - void . flip runStateT def . runInputT settings . runWriterT $ runCli + void . flip runStateT def . runInputT settings $ runCli + +-- data Cmd = PerformAlt Alteration (Maybe Comment) +-- | ShowTip +-- | ShowHistory (Maybe Integer) +-- | Dump -runCli :: (MonadIO m, MonadException m) => SequenceT m () +runCli :: (MonadIO m, MonadException m, SequenceM m) => InputT m () runCli = do - input <- lift $ getInputLine "→ " + input <- getInputLine "→ " case input of Nothing -> liftIO exitSuccess Just input' -> do cmd <- parseCmd input' case cmd of - UnknownCommand help -> do - lift . outputStrLn $ help - ParseError err -> do - lift . outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err - Empty -> return () + UnknownCommand help -> do + outputStrLn $ help + ParseError err -> do + outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err + Empty -> return () - Quit -> liftIO exitSuccess + Quit -> liftIO exitSuccess + Dump -> get >>= outputStrLn . show + ShowTip -> do + tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence) + case tip of + Just entity -> outputStrLn . Text.unpack $ showEntity entity + Nothing -> outputStrLn "Queue is currently empty" + ShowHistory ns -> do + let sel = maybe id takeR ns + mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory + PerformAlt alt comment -> apply' alt comment _ -> undefined runCli diff --git a/src/Types.hs b/src/Types.hs index 10cea7a..a90e5fe 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -8,6 +8,7 @@ module Types , Alteration(..) , Sequence , History + , Context(..) , SequenceM ) where @@ -15,6 +16,7 @@ import Data.PQueue.Prio.Max (MaxPQueue) import qualified Data.PQueue.Prio.Max as MaxPQueue (empty) import Data.Sequence (Seq) +import qualified Data.Sequence as Seq (empty) import Data.Text (Text) @@ -46,12 +48,21 @@ type Sequence = MaxPQueue SequenceValue Entity type History = Seq (Alteration, Comment) -type SequenceM m = (MonadWriter History m, MonadState Sequence m, MonadIO m) +data Context = Context + { ctxSequence :: Sequence + , ctxHistory :: History + } + deriving (Show) + +type SequenceM m = (MonadState Context m, MonadIO m) instance MonadState s m => MonadState s (InputT m) where get = lift get put = lift . put state = lift . state -instance Default (MaxPQueue k v) where - def = MaxPQueue.empty +instance Default Context where + def = Context + { ctxSequence = MaxPQueue.empty + , ctxHistory = Seq.empty + } diff --git a/src/Utils.hs b/src/Utils.hs index 6c8f0c1..cac88ac 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -4,6 +4,7 @@ module Utils ( showEntity , apply, apply' , entities + , takeR ) where import Data.Text (Text) @@ -20,6 +21,9 @@ import Control.Monad.Writer.Class import Data.Set (Set) import qualified Data.Set as Set +import Data.Sequence (Seq, ViewR(..), (|>)) +import qualified Data.Sequence as Seq + import Types showEntity :: Entity -> Text @@ -27,14 +31,19 @@ showEntity (Entity name number) | (Just (show -> n)) <- number = name <> " № " <> Text.pack n | otherwise = name -apply' :: (MonadState Sequence m, MonadWriter History m) => Alteration -> m () -apply' alteration = do - (newSt, hist) <- apply alteration <$> get - tell hist - put newSt +apply' :: MonadState Context m => Alteration -> Comment -> m () +apply' alteration comment = modify $ onCtx (apply alteration comment) + where + onCtx f ctx = let (sequence', history') = f $ ctxSequence ctx in ctx { ctxSequence = sequence', ctxHistory = ctxHistory ctx <> history' } -apply :: Alteration -> Sequence -> (Sequence, History) -apply alteration seq = undefined +apply :: Alteration -> Comment -> Sequence -> (Sequence, History) +apply alteration comment seq = undefined entities :: MonadState Sequence m => m (Set Entity) entities = Set.fromList . MaxPQueue.elems <$> get + +takeR :: Integer -> Seq a -> Seq a +takeR _ (Seq.viewr -> EmptyR) = Seq.empty +takeR n (Seq.viewr -> (xs :> x)) + | n <= 0 = Seq.empty + | otherwise = takeR (n - 1) xs |> x -- cgit v1.2.3