Feature completionHEADmaster

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
 
 import Data.Maybe (fromMaybe)
 
+import           Data.CaseInsensitive  ( CI )
+import qualified Data.CaseInsensitive as CI
+  
 import Types
 
 data Cmd = PerformAlt Alteration Comment
@@ -85,7 +88,7 @@ parseCmd' args = do
 
 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 "list" $ pure Dump `info` progDesc "Print a list of tracked entities"
                                      , 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"
@@ -116,7 +119,7 @@ cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDes
     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")
+    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")
 
     sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE")
     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 @@
-{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings, TupleSections #-}
 
 import           Data.PQueue.Prio.Max (MaxPQueue)
 import qualified Data.PQueue.Prio.Max as MaxPQueue
@@ -9,8 +9,11 @@ import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import Data.Default.Class
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing, fromJust)
 
 import System.Environment.XDG.BaseDir (getUserCacheFile)
 import System.Environment (getProgName)
@@ -54,7 +57,7 @@ runCli = do
 
         Quit                   -> liftIO exitSuccess
 
-        Dump                   -> get >>= outputStrLn . show
+        Dump                   -> gets ctxSequence >>= mapM_ (outputStrLn . showAssoc) . MaxPQueue.toDescList
         ShowTip                -> do
           tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence)
           case tip of
@@ -63,6 +66,57 @@ runCli = do
         ShowHistory ns         -> do
           let sel = maybe id takeR ns
           mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory
-        PerformAlt alt comment -> apply' alt comment
+        PerformAlt alt comment -> apply alt comment
         _              -> undefined
   runCli
+
+showAssoc :: (SequenceValue, Entity) -> String
+showAssoc (val, entity) = show val <> "\t" <> (Text.unpack $ showEntity entity)
+
+
+apply :: SequenceM m => Alteration -> Comment -> InputT m ()
+apply alteration comment = alter alteration >> modify (\ctx -> ctx { ctxHistory = ctxHistory ctx |> (alteration, comment) })
+
+alter :: SequenceM m => Alteration -> InputT m ()
+alter (Modify entity ((+) -> mod)) = alterMatching entity mod
+alter (Override entity (const -> mod)) = alterMatching entity mod
+alter (Rename old new) = do
+  [(k, _)] <- filter (\(_, v) -> v == old) <$> gets (MaxPQueue.assocsU . ctxSequence)
+  alter (Drop old)
+  alter (Insert new k)
+alter (Drop entity) = do
+  (matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence
+  modify $ \ctx -> ctx { ctxSequence = notMatching }
+  when (MaxPQueue.null matching) warnEmpty
+alter (Insert entity val) = do
+  modify $ \ctx -> ctx { ctxSequence = MaxPQueue.insert val entity $ ctxSequence ctx }
+  introduceNumbering entity
+
+
+alterMatching :: SequenceM m => Entity -> (SequenceValue -> SequenceValue) -> InputT m ()
+alterMatching entity mod = do
+  (matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence
+  modify $ \ctx -> ctx { ctxSequence = notMatching `MaxPQueue.union` MaxPQueue.mapKeys mod matching }
+  when (MaxPQueue.null matching) warnEmpty
+
+introduceNumbering :: SequenceM m => Entity -> InputT m ()
+introduceNumbering entity = do
+  let
+    matches (Entity name _) (Entity name' _) = name == name'
+  (matching, notMatching) <- MaxPQueue.partition (matches entity) <$> gets ctxSequence
+  if MaxPQueue.size matching <= 1
+    then return ()
+    else do
+    let
+      (matching', notMatching') = MaxPQueue.partition (\(Entity _ n) -> isNothing n) matching
+      maxN = MaxPQueue.foldrU (\(Entity _ n) -> max n) (Just 0) notMatching'
+    modify $ \ctx -> ctx { ctxSequence = snd $ MaxPQueue.foldrWithKey accum (fromJust maxN, MaxPQueue.union notMatching notMatching') matching' }
+    if MaxPQueue.null notMatching'
+      then outputStrLn $ "Had to introduce a numbering scheme to differentiate multiple entities called »" <> (Text.unpack $ showEntity entity) <> "«"
+      else outputStrLn $ "Inserted new entity called »" <> (Text.unpack $ showEntity entity) <> "« into existing numbering scheme"
+  where
+    accum key (Entity val _) (n, queue) = (succ n, MaxPQueue.insert key (Entity val $ Just (succ n)) queue) 
+
+warnEmpty :: MonadIO m => InputT m ()
+warnEmpty = outputStrLn "Selection did not match any entities"
+
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)
 
 import Data.Default.Class
 
+import Data.CaseInsensitive (CI)
+
 import Control.Monad.State.Strict (MonadState(..), MonadTrans(..))
 import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..))
 
@@ -30,7 +32,7 @@ import Control.Monad.IO.Class (MonadIO)
 import System.Console.Haskeline (InputT)
 
   
-data Entity = Entity Text (Maybe Integer)
+data Entity = Entity (CI Text) (Maybe Integer)
             deriving (Eq, Ord, Show)
 
 type 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 @@
 
 module Utils
        ( showEntity
-       , apply, apply'
-       , entities
        , takeR
        ) where
 
@@ -24,23 +22,15 @@ import qualified Data.Set as Set
 import Data.Sequence (Seq, ViewR(..), (|>))
 import qualified Data.Sequence as Seq
 
+import           Data.CaseInsensitive  ( CI )
+import qualified Data.CaseInsensitive as CI
+
 import Types
 
 showEntity :: Entity -> Text
 showEntity (Entity name number)
-  | (Just (show -> n)) <- number = name <> " № " <> Text.pack n
-  | otherwise = name
-
-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 -> Comment -> Sequence -> (Sequence, History)
-apply alteration comment seq = undefined
-
-entities :: MonadState Sequence m => m (Set Entity)
-entities = Set.fromList . MaxPQueue.elems <$> get
+  | (Just (show -> n)) <- number = CI.original name <> " № " <> Text.pack n
+  | otherwise = CI.original name
 
 takeR :: Integer -> Seq a -> Seq a
 takeR _ (Seq.viewr -> EmptyR) = Seq.empty