1
{-# LANGUAGE NamedFieldPuns, DeriveTraversable #-}
2
3
-----------------------------------------------------------------------------
4
-- |
5
-- Module      :  XMonad.Util.History
6
-- Description :  Track history in /O(log n)/ time.
7
-- Copyright   :  (c) 2022 L. S. Leary
8
-- License     :  BSD3-style (see LICENSE)
9
--
10
-- Maintainer  :  @LSLeary (on github)
11
-- Stability   :  unstable
12
-- Portability :  unportable
13
--
14
-- Provides 'History', a variation on a LIFO stack with a uniqueness property.
15
-- In order to achieve the desired asymptotics, the data type is implemented as
16
-- an ordered Map.
17
--
18
-----------------------------------------------------------------------------
19
20
module XMonad.Util.History (
21
  History,
22
  origin,
23
  event,
24
  erase,
25
  recall,
26
  ledger,
27
  transcribe,
28
  ) where
29
30
-- base
31
import Data.Function (on)
32
import Text.Read
33
  ( Read(readPrec, readListPrec), Lexeme(Ident)
34
  , parens, prec, lexP, step, readListPrecDefault
35
  )
36
37
-- containers
38
import Data.IntMap (IntMap)
39
import qualified Data.IntMap.Strict as I
40
import Data.Map (Map)
41
import qualified Data.Map.Strict as M
42
43
44
-- | A history of unique @k@-events with @a@-annotations.
45
--
46
--   @History k a@ can be considered a (LIFO) stack of @(k, a)@ values with the
47
--   property that each @k@ is unique. From this point of view, 'event' pushes
48
--   and 'ledger' pops/peeks all.
49
--
50
--   The naive implementation has /O(n)/ 'event' and 'erase' due to the
51
--   uniqueness condition, but we can still use it as a denotation:
52
--
53
-- > mu :: History k a -> [(k, a)]
54
--
55
--   As an opaque data type with strict operations, @History k a@ values are all
56
--   finite expressions in the core interface: 'origin', 'erase' and 'event'.
57
--   Hence we define @mu@ by structural induction on these three cases.
58
--
59
data History k a = History
60
  { annals   :: !(IntMap (k, a))
61
  , recorded :: !(Map k Int)
62
  } deriving (Functor, Foldable, Traversable)
63
64
instance (Eq  k, Eq  a) => Eq  (History k a) where (==)    = (==)    `on` ledger
65
instance (Ord k, Ord a) => Ord (History k a) where compare = compare `on` ledger
66
67
instance (Show k, Show a) => Show (History k a) where
68
  showsPrec d h
69
    = showParen (d > app_prec)
70
    $ showString "transcribe "
71
    . showsPrec (app_prec+1) (ledger h)
72
    where app_prec = 10
73
74
instance (Read k, Read a, Ord k) => Read (History k a) where
75
  readPrec = parens . prec app_prec $ do
76
    Ident "transcribe" <- lexP
77
    l <- step readPrec
78
    pure (transcribe l)
79
    where app_prec = 10
80
  readListPrec = readListPrecDefault
81
82
83
-- | /O(1)/. A history of nothing.
84
--
85
-- > mu origin := []
86
--
87
origin :: History k a
88
origin = History I.empty M.empty
89
90
-- | /O(log n)/. A new event makes history; its predecessor forgotten.
91
--
92
-- > mu (event k a h) := (k, a) : mu (erase k h)
93
--
94
event :: Ord k => k -> a -> History k a -> History k a
95
event k a History{annals,recorded} = History
96
  { annals   = I.insert ik (k, a) . maybe id I.delete mseen $ annals
97
  , recorded = recorded'
98
  }
99
  where
100
    ik = maybe 0 (\((i, _), _) -> pred i) (I.minViewWithKey annals)
101
    (mseen, recorded') = M.insertLookupWithKey (\_ x _ -> x) k ik recorded
102
103
-- | /O(log n)/. Erase an event from history.
104
--
105
-- > mu (erase k h) := filter ((k /=) . fst) (mu h)
106
--
107
erase :: Ord k => k -> History k a -> History k a
108
erase k History{annals,recorded} = History
109
  { annals   = maybe id I.delete mseen annals
110
  , recorded = recorded'
111
  }
112
  where (mseen, recorded') = M.updateLookupWithKey (\_ _ -> Nothing) k recorded
113
114
115
-- | /O(log n)/. Recall an event.
116
recall :: Ord k => k -> History k a -> Maybe a
117
recall k History{annals,recorded} = do
118
  ik     <- M.lookup k recorded
119
  (_, a) <- I.lookup ik annals
120
  pure a
121
122
-- | /O(n)/. Read history, starting with the modern day. @ledger@ is @mu@.
123
ledger :: History k a -> [(k, a)]
124
ledger = I.elems . annals
125
126
-- | /O(n * log n)/. Transcribe a ledger.
127
transcribe :: Ord k => [(k, a)] -> History k a
128
transcribe = foldr (uncurry event) origin