From e66d94505776ec13259bedde4e5342985322a482 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 8 May 2016 02:09:04 +0200
Subject: Feature completion

---
 src/Main.hs | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 58 insertions(+), 4 deletions(-)

(limited to 'src/Main.hs')

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"
+
-- 
cgit v1.2.3