summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Command.hs11
-rw-r--r--src/Main.hs38
-rw-r--r--src/Types.hs17
-rw-r--r--src/Utils.hs23
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 @@
1{-# LANGUAGE FlexibleContexts #-} 1{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
2 2
3module Command 3module Command
4 ( Cmd(..) 4 ( Cmd(..)
@@ -21,7 +21,7 @@ import Data.Maybe (fromMaybe)
21 21
22import Types 22import Types
23 23
24data Cmd = PerformAlt Alteration (Maybe Comment) 24data Cmd = PerformAlt Alteration Comment
25 | ShowTip 25 | ShowTip
26 | ShowHistory (Maybe Integer) 26 | ShowHistory (Maybe Integer)
27 | Dump 27 | Dump
@@ -74,7 +74,7 @@ parseCmd = parseCmd' . split
74parseCmd' :: SequenceM m => [String] -> m Cmd 74parseCmd' :: SequenceM m => [String] -> m Cmd
75parseCmd' [] = return Empty 75parseCmd' [] = return Empty
76parseCmd' args = do 76parseCmd' args = do
77 tip <- fmap snd <$> gets MaxPQueue.getMax 77 tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence)
78 let 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 79 runParser = execParserPure (prefs $ showHelpOnError) (cmdParser tip `info` progDesc "sequence - A tracker for combat sequences in Contact (a pen&paper rpg by Uhrwerk)") args
80 return $ mapResult runParser 80 return $ mapResult runParser
@@ -121,8 +121,5 @@ cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDes
121 sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE") 121 sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE")
122 sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE") 122 sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE")
123 123
124 comment = toMaybe . fmap Text.pack <$> optional (strArgument $ help "Comment to record in history together with this action" <> metavar "COMMENT") 124 comment = fromMaybe "" . 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 125 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
6import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..)) 6import Data.Sequence (Seq, (|>), (<|), viewl, viewr, ViewL(..), ViewR(..))
7import qualified Data.Sequence as Seq 7import qualified Data.Sequence as Seq
8 8
9import Data.Text (Text)
10import qualified Data.Text as Text
11
9import Data.Default.Class 12import Data.Default.Class
10import Data.Maybe (fromMaybe) 13import Data.Maybe (fromMaybe)
11 14
@@ -23,30 +26,43 @@ import Types
23import Utils 26import Utils
24import Command 27import Command
25 28
26type SequenceT m a = WriterT History (InputT (StateT Sequence m)) a
27
28main :: IO () 29main :: IO ()
29main = do 30main = do
30 historyFile <- flip getUserCacheFile "history" =<< getProgName 31 historyFile <- flip getUserCacheFile "history" =<< getProgName
31 let 32 let
32 settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings 33 settings = setComplete noCompletion {- TODO -} . (\x -> x { historyFile = Just historyFile }) $ defaultSettings
33 void . flip runStateT def . runInputT settings . runWriterT $ runCli 34 void . flip runStateT def . runInputT settings $ runCli
35
36-- data Cmd = PerformAlt Alteration (Maybe Comment)
37-- | ShowTip
38-- | ShowHistory (Maybe Integer)
39-- | Dump
34 40
35runCli :: (MonadIO m, MonadException m) => SequenceT m () 41runCli :: (MonadIO m, MonadException m, SequenceM m) => InputT m ()
36runCli = do 42runCli = do
37 input <- lift $ getInputLine "→ " 43 input <- getInputLine "→ "
38 case input of 44 case input of
39 Nothing -> liftIO exitSuccess 45 Nothing -> liftIO exitSuccess
40 Just input' -> do 46 Just input' -> do
41 cmd <- parseCmd input' 47 cmd <- parseCmd input'
42 case cmd of 48 case cmd of
43 UnknownCommand help -> do 49 UnknownCommand help -> do
44 lift . outputStrLn $ help 50 outputStrLn $ help
45 ParseError err -> do 51 ParseError err -> do
46 lift . outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err 52 outputStrLn $ "Error parsing input »" <> (fromMaybe "" input) <> "«: " <> err
47 Empty -> return () 53 Empty -> return ()
48 54
49 Quit -> liftIO exitSuccess 55 Quit -> liftIO exitSuccess
50 56
57 Dump -> get >>= outputStrLn . show
58 ShowTip -> do
59 tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence)
60 case tip of
61 Just entity -> outputStrLn . Text.unpack $ showEntity entity
62 Nothing -> outputStrLn "Queue is currently empty"
63 ShowHistory ns -> do
64 let sel = maybe id takeR ns
65 mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory
66 PerformAlt alt comment -> apply' alt comment
51 _ -> undefined 67 _ -> undefined
52 runCli 68 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
8 , Alteration(..) 8 , Alteration(..)
9 , Sequence 9 , Sequence
10 , History 10 , History
11 , Context(..)
11 , SequenceM 12 , SequenceM
12 ) where 13 ) where
13 14
@@ -15,6 +16,7 @@ import Data.PQueue.Prio.Max (MaxPQueue)
15import qualified Data.PQueue.Prio.Max as MaxPQueue (empty) 16import qualified Data.PQueue.Prio.Max as MaxPQueue (empty)
16 17
17import Data.Sequence (Seq) 18import Data.Sequence (Seq)
19import qualified Data.Sequence as Seq (empty)
18 20
19import Data.Text (Text) 21import Data.Text (Text)
20 22
@@ -46,12 +48,21 @@ type Sequence = MaxPQueue SequenceValue Entity
46 48
47type History = Seq (Alteration, Comment) 49type History = Seq (Alteration, Comment)
48 50
49type SequenceM m = (MonadWriter History m, MonadState Sequence m, MonadIO m) 51data Context = Context
52 { ctxSequence :: Sequence
53 , ctxHistory :: History
54 }
55 deriving (Show)
56
57type SequenceM m = (MonadState Context m, MonadIO m)
50 58
51instance MonadState s m => MonadState s (InputT m) where 59instance MonadState s m => MonadState s (InputT m) where
52 get = lift get 60 get = lift get
53 put = lift . put 61 put = lift . put
54 state = lift . state 62 state = lift . state
55 63
56instance Default (MaxPQueue k v) where 64instance Default Context where
57 def = MaxPQueue.empty 65 def = Context
66 { ctxSequence = MaxPQueue.empty
67 , ctxHistory = Seq.empty
68 }
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
4 ( showEntity 4 ( showEntity
5 , apply, apply' 5 , apply, apply'
6 , entities 6 , entities
7 , takeR
7 ) where 8 ) where
8 9
9import Data.Text (Text) 10import Data.Text (Text)
@@ -20,6 +21,9 @@ import Control.Monad.Writer.Class
20import Data.Set (Set) 21import Data.Set (Set)
21import qualified Data.Set as Set 22import qualified Data.Set as Set
22 23
24import Data.Sequence (Seq, ViewR(..), (|>))
25import qualified Data.Sequence as Seq
26
23import Types 27import Types
24 28
25showEntity :: Entity -> Text 29showEntity :: Entity -> Text
@@ -27,14 +31,19 @@ showEntity (Entity name number)
27 | (Just (show -> n)) <- number = name <> " № " <> Text.pack n 31 | (Just (show -> n)) <- number = name <> " № " <> Text.pack n
28 | otherwise = name 32 | otherwise = name
29 33
30apply' :: (MonadState Sequence m, MonadWriter History m) => Alteration -> m () 34apply' :: MonadState Context m => Alteration -> Comment -> m ()
31apply' alteration = do 35apply' alteration comment = modify $ onCtx (apply alteration comment)
32 (newSt, hist) <- apply alteration <$> get 36 where
33 tell hist 37 onCtx f ctx = let (sequence', history') = f $ ctxSequence ctx in ctx { ctxSequence = sequence', ctxHistory = ctxHistory ctx <> history' }
34 put newSt
35 38
36apply :: Alteration -> Sequence -> (Sequence, History) 39apply :: Alteration -> Comment -> Sequence -> (Sequence, History)
37apply alteration seq = undefined 40apply alteration comment seq = undefined
38 41
39entities :: MonadState Sequence m => m (Set Entity) 42entities :: MonadState Sequence m => m (Set Entity)
40entities = Set.fromList . MaxPQueue.elems <$> get 43entities = Set.fromList . MaxPQueue.elems <$> get
44
45takeR :: Integer -> Seq a -> Seq a
46takeR _ (Seq.viewr -> EmptyR) = Seq.empty
47takeR n (Seq.viewr -> (xs :> x))
48 | n <= 0 = Seq.empty
49 | otherwise = takeR (n - 1) xs |> x