diff --git a/CHANGES.md b/CHANGES.md index 94dbbe3d..3816f1fb 100644 --- a/CHANGES.md +++ b/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 diff --git a/XMonad/Util/History.hs b/XMonad/Util/History.hs new file mode 100644 index 00000000..07dcaf71 --- /dev/null +++ b/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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 7d5da602..45b8f3e9 100644 --- a/xmonad-contrib.cabal +++ b/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