summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Command.hs7
-rw-r--r--src/Main.hs62
-rw-r--r--src/Types.hs4
-rw-r--r--src/Utils.hs20
4 files changed, 71 insertions, 22 deletions
diff --git a/src/Command.hs b/src/Command.hs
index 659d14d..127e986 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -19,6 +19,9 @@ import qualified Data.Text as Text
19 19
20import Data.Maybe (fromMaybe) 20import Data.Maybe (fromMaybe)
21 21
22import Data.CaseInsensitive ( CI )
23import qualified Data.CaseInsensitive as CI
24
22import Types 25import Types
23 26
24data Cmd = PerformAlt Alteration Comment 27data Cmd = PerformAlt Alteration Comment
@@ -85,7 +88,7 @@ parseCmd' args = do
85 88
86cmdParser :: Maybe Entity -> Parser Cmd 89cmdParser :: Maybe Entity -> Parser Cmd
87cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully" 90cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully"
88 , command "dump" $ pure Dump `info` progDesc "Print all internal state in a format not necessarily human readable" 91 , command "list" $ pure Dump `info` progDesc "Print a list of tracked entities"
89 , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history" 92 , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history"
90 , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?" 93 , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?"
91 , command "set" $ parseOverride `info` progDesc "Set an entities sequence value" 94 , command "set" $ parseOverride `info` progDesc "Set an entities sequence value"
@@ -116,7 +119,7 @@ cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDes
116 entity 119 entity
117 | (Just tip') <- tip = fromMaybe tip' <$> optional entity' 120 | (Just tip') <- tip = fromMaybe tip' <$> optional entity'
118 | otherwise = entity' 121 | 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") 122 entity' = Entity <$> (CI.mk . Text.pack <$> strArgument (help "Name of the target entity" <> metavar "NAME")) <*> optional (option positive $ long "number" <> short 'n' <> help "Number of the target entity" <> metavar "NUMBER")
120 123
121 sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE") 124 sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE")
122 sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE") 125 sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE")
diff --git a/src/Main.hs b/src/Main.hs
index 86c8771..4429853 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,4 +1,4 @@
1{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-} 1{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings, TupleSections #-}
2 2
3import Data.PQueue.Prio.Max (MaxPQueue) 3import Data.PQueue.Prio.Max (MaxPQueue)
4import qualified Data.PQueue.Prio.Max as MaxPQueue 4import qualified Data.PQueue.Prio.Max as MaxPQueue
@@ -9,8 +9,11 @@ import qualified Data.Sequence as Seq
9import Data.Text (Text) 9import Data.Text (Text)
10import qualified Data.Text as Text 10import qualified Data.Text as Text
11 11
12import Data.Set (Set)
13import qualified Data.Set as Set
14
12import Data.Default.Class 15import Data.Default.Class
13import Data.Maybe (fromMaybe) 16import Data.Maybe (fromMaybe, isNothing, fromJust)
14 17
15import System.Environment.XDG.BaseDir (getUserCacheFile) 18import System.Environment.XDG.BaseDir (getUserCacheFile)
16import System.Environment (getProgName) 19import System.Environment (getProgName)
@@ -54,7 +57,7 @@ runCli = do
54 57
55 Quit -> liftIO exitSuccess 58 Quit -> liftIO exitSuccess
56 59
57 Dump -> get >>= outputStrLn . show 60 Dump -> gets ctxSequence >>= mapM_ (outputStrLn . showAssoc) . MaxPQueue.toDescList
58 ShowTip -> do 61 ShowTip -> do
59 tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence) 62 tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence)
60 case tip of 63 case tip of
@@ -63,6 +66,57 @@ runCli = do
63 ShowHistory ns -> do 66 ShowHistory ns -> do
64 let sel = maybe id takeR ns 67 let sel = maybe id takeR ns
65 mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory 68 mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory
66 PerformAlt alt comment -> apply' alt comment 69 PerformAlt alt comment -> apply alt comment
67 _ -> undefined 70 _ -> undefined
68 runCli 71 runCli
72
73showAssoc :: (SequenceValue, Entity) -> String
74showAssoc (val, entity) = show val <> "\t" <> (Text.unpack $ showEntity entity)
75
76
77apply :: SequenceM m => Alteration -> Comment -> InputT m ()
78apply alteration comment = alter alteration >> modify (\ctx -> ctx { ctxHistory = ctxHistory ctx |> (alteration, comment) })
79
80alter :: SequenceM m => Alteration -> InputT m ()
81alter (Modify entity ((+) -> mod)) = alterMatching entity mod
82alter (Override entity (const -> mod)) = alterMatching entity mod
83alter (Rename old new) = do
84 [(k, _)] <- filter (\(_, v) -> v == old) <$> gets (MaxPQueue.assocsU . ctxSequence)
85 alter (Drop old)
86 alter (Insert new k)
87alter (Drop entity) = do
88 (matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence
89 modify $ \ctx -> ctx { ctxSequence = notMatching }
90 when (MaxPQueue.null matching) warnEmpty
91alter (Insert entity val) = do
92 modify $ \ctx -> ctx { ctxSequence = MaxPQueue.insert val entity $ ctxSequence ctx }
93 introduceNumbering entity
94
95
96alterMatching :: SequenceM m => Entity -> (SequenceValue -> SequenceValue) -> InputT m ()
97alterMatching entity mod = do
98 (matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence
99 modify $ \ctx -> ctx { ctxSequence = notMatching `MaxPQueue.union` MaxPQueue.mapKeys mod matching }
100 when (MaxPQueue.null matching) warnEmpty
101
102introduceNumbering :: SequenceM m => Entity -> InputT m ()
103introduceNumbering entity = do
104 let
105 matches (Entity name _) (Entity name' _) = name == name'
106 (matching, notMatching) <- MaxPQueue.partition (matches entity) <$> gets ctxSequence
107 if MaxPQueue.size matching <= 1
108 then return ()
109 else do
110 let
111 (matching', notMatching') = MaxPQueue.partition (\(Entity _ n) -> isNothing n) matching
112 maxN = MaxPQueue.foldrU (\(Entity _ n) -> max n) (Just 0) notMatching'
113 modify $ \ctx -> ctx { ctxSequence = snd $ MaxPQueue.foldrWithKey accum (fromJust maxN, MaxPQueue.union notMatching notMatching') matching' }
114 if MaxPQueue.null notMatching'
115 then outputStrLn $ "Had to introduce a numbering scheme to differentiate multiple entities called »" <> (Text.unpack $ showEntity entity) <> "«"
116 else outputStrLn $ "Inserted new entity called »" <> (Text.unpack $ showEntity entity) <> "« into existing numbering scheme"
117 where
118 accum key (Entity val _) (n, queue) = (succ n, MaxPQueue.insert key (Entity val $ Just (succ n)) queue)
119
120warnEmpty :: MonadIO m => InputT m ()
121warnEmpty = outputStrLn "Selection did not match any entities"
122
diff --git a/src/Types.hs b/src/Types.hs
index a90e5fe..031d2d5 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -22,6 +22,8 @@ import Data.Text (Text)
22 22
23import Data.Default.Class 23import Data.Default.Class
24 24
25import Data.CaseInsensitive (CI)
26
25import Control.Monad.State.Strict (MonadState(..), MonadTrans(..)) 27import Control.Monad.State.Strict (MonadState(..), MonadTrans(..))
26import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..)) 28import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..))
27 29
@@ -30,7 +32,7 @@ import Control.Monad.IO.Class (MonadIO)
30import System.Console.Haskeline (InputT) 32import System.Console.Haskeline (InputT)
31 33
32 34
33data Entity = Entity Text (Maybe Integer) 35data Entity = Entity (CI Text) (Maybe Integer)
34 deriving (Eq, Ord, Show) 36 deriving (Eq, Ord, Show)
35 37
36type SequenceValue = Integer 38type SequenceValue = Integer
diff --git a/src/Utils.hs b/src/Utils.hs
index cac88ac..b98359a 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -2,8 +2,6 @@
2 2
3module Utils 3module Utils
4 ( showEntity 4 ( showEntity
5 , apply, apply'
6 , entities
7 , takeR 5 , takeR
8 ) where 6 ) where
9 7
@@ -24,23 +22,15 @@ import qualified Data.Set as Set
24import Data.Sequence (Seq, ViewR(..), (|>)) 22import Data.Sequence (Seq, ViewR(..), (|>))
25import qualified Data.Sequence as Seq 23import qualified Data.Sequence as Seq
26 24
25import Data.CaseInsensitive ( CI )
26import qualified Data.CaseInsensitive as CI
27
27import Types 28import Types
28 29
29showEntity :: Entity -> Text 30showEntity :: Entity -> Text
30showEntity (Entity name number) 31showEntity (Entity name number)
31 | (Just (show -> n)) <- number = name <> " № " <> Text.pack n 32 | (Just (show -> n)) <- number = CI.original name <> " № " <> Text.pack n
32 | otherwise = name 33 | otherwise = CI.original name
33
34apply' :: MonadState Context m => Alteration -> Comment -> m ()
35apply' alteration comment = modify $ onCtx (apply alteration comment)
36 where
37 onCtx f ctx = let (sequence', history') = f $ ctxSequence ctx in ctx { ctxSequence = sequence', ctxHistory = ctxHistory ctx <> history' }
38
39apply :: Alteration -> Comment -> Sequence -> (Sequence, History)
40apply alteration comment seq = undefined
41
42entities :: MonadState Sequence m => m (Set Entity)
43entities = Set.fromList . MaxPQueue.elems <$> get
44 34
45takeR :: Integer -> Seq a -> Seq a 35takeR :: Integer -> Seq a -> Seq a
46takeR _ (Seq.viewr -> EmptyR) = Seq.empty 36takeR _ (Seq.viewr -> EmptyR) = Seq.empty