Write new module: X.U.History

CHANGES.md

@@ -77,6 +77,12 @@
 
 ### New Modules
 
+  * `XMonad.Util.History`
+
+    - Track history in *O(log n)* time. Provides `History`, a variation on a
+      LIFO stack with a uniqueness property. In order to achieve the desired
+      asymptotics, the data type is implemented as an ordered Map.
+
   * `XMonad.Actions.Repeatable`
 
     - Actions you'd like to repeat. Factors out the shared logic of

XMonad/Util/History.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE NamedFieldPuns, DeriveTraversable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Util.History
+-- Description :  Track history in /O(log n)/ time.
+-- Copyright   :  (c) 2022 L. S. Leary
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  @LSLeary (on github)
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Provides 'History', a variation on a LIFO stack with a uniqueness property.
+-- In order to achieve the desired asymptotics, the data type is implemented as
+-- an ordered Map.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Util.History (
+  History,
+  origin,
+  event,
+  erase,
+  recall,
+  ledger,
+  transcribe,
+  ) where
+
+-- base
+import Data.Function (on)
+import Text.Read
+  ( Read(readPrec, readListPrec), Lexeme(Ident)
+  , parens, prec, lexP, step, readListPrecDefault
+  )
+
+-- containers
+import Data.IntMap (IntMap)
+import qualified Data.IntMap.Strict as I
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
+
+
+-- | A history of unique @k@-events with @a@-annotations.
+--
+--   @History k a@ can be considered a (LIFO) stack of @(k, a)@ values with the
+--   property that each @k@ is unique. From this point of view, 'event' pushes
+--   and 'ledger' pops/peeks all.
+--
+--   The naive implementation has /O(n)/ 'event' and 'erase' due to the
+--   uniqueness condition, but we can still use it as a denotation:
+--
+-- > mu :: History k a -> [(k, a)]
+--
+--   As an opaque data type with strict operations, @History k a@ values are all
+--   finite expressions in the core interface: 'origin', 'erase' and 'event'.
+--   Hence we define @mu@ by structural induction on these three cases.
+--
+data History k a = History
+  { annals   :: !(IntMap (k, a))
+  , recorded :: !(Map k Int)
+  } deriving (Functor, Foldable, Traversable)
+
+instance (Eq  k, Eq  a) => Eq  (History k a) where (==)    = (==)    `on` ledger
+instance (Ord k, Ord a) => Ord (History k a) where compare = compare `on` ledger
+
+instance (Show k, Show a) => Show (History k a) where
+  showsPrec d h
+    = showParen (d > app_prec)
+    $ showString "transcribe "
+    . showsPrec (app_prec+1) (ledger h)
+    where app_prec = 10
+
+instance (Read k, Read a, Ord k) => Read (History k a) where
+  readPrec = parens . prec app_prec $ do
+    Ident "transcribe" <- lexP
+    l <- step readPrec
+    pure (transcribe l)
+    where app_prec = 10
+  readListPrec = readListPrecDefault
+
+
+-- | /O(1)/. A history of nothing.
+--
+-- > mu origin := []
+--
+origin :: History k a
+origin = History I.empty M.empty
+
+-- | /O(log n)/. A new event makes history; its predecessor forgotten.
+--
+-- > mu (event k a h) := (k, a) : mu (erase k h)
+--
+event :: Ord k => k -> a -> History k a -> History k a
+event k a History{annals,recorded} = History
+  { annals   = I.insert ik (k, a) . maybe id I.delete mseen $ annals
+  , recorded = recorded'
+  }
+  where
+    ik = maybe 0 (\((i, _), _) -> pred i) (I.minViewWithKey annals)
+    (mseen, recorded') = M.insertLookupWithKey (\_ x _ -> x) k ik recorded
+
+-- | /O(log n)/. Erase an event from history.
+--
+-- > mu (erase k h) := filter ((k /=) . fst) (mu h)
+--
+erase :: Ord k => k -> History k a -> History k a
+erase k History{annals,recorded} = History
+  { annals   = maybe id I.delete mseen annals
+  , recorded = recorded'
+  }
+  where (mseen, recorded') = M.updateLookupWithKey (\_ _ -> Nothing) k recorded
+
+
+-- | /O(log n)/. Recall an event.
+recall :: Ord k => k -> History k a -> Maybe a
+recall k History{annals,recorded} = do
+  ik     <- M.lookup k recorded
+  (_, a) <- I.lookup ik annals
+  pure a
+
+-- | /O(n)/. Read history, starting with the modern day. @ledger@ is @mu@.
+ledger :: History k a -> [(k, a)]
+ledger = I.elems . annals
+
+-- | /O(n * log n)/. Transcribe a ledger.
+transcribe :: Ord k => [(k, a)] -> History k a
+transcribe = foldr (uncurry event) origin

xmonad-contrib.cabal

@@ -361,6 +361,7 @@ library
                         XMonad.Util.Font
                         XMonad.Util.Grab
                         XMonad.Util.Hacks
+                        XMonad.Util.History
                         XMonad.Util.Image
                         XMonad.Util.Invisible
                         XMonad.Util.Loggers