command interpretation

4 files changed, 61 insertions, 28 deletions

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