{-# 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
  { forall k a. History k a -> IntMap (k, a)
annals   :: !(IntMap (k, a))
  , forall k a. History k a -> Map k Int
recorded :: !(Map k Int)
  } deriving (forall a b. a -> History k b -> History k a
forall a b. (a -> b) -> History k a -> History k b
forall k a b. a -> History k b -> History k a
forall k a b. (a -> b) -> History k a -> History k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> History k b -> History k a
$c<$ :: forall k a b. a -> History k b -> History k a
fmap :: forall a b. (a -> b) -> History k a -> History k b
$cfmap :: forall k a b. (a -> b) -> History k a -> History k b
Functor, forall a. History k a -> Bool
forall k a. Eq a => a -> History k a -> Bool
forall k a. Num a => History k a -> a
forall k a. Ord a => History k a -> a
forall m a. Monoid m => (a -> m) -> History k a -> m
forall k m. Monoid m => History k m -> m
forall k a. History k a -> Bool
forall k a. History k a -> Int
forall k a. History k a -> [a]
forall a b. (a -> b -> b) -> b -> History k a -> b
forall k a. (a -> a -> a) -> History k a -> a
forall k m a. Monoid m => (a -> m) -> History k a -> m
forall k b a. (b -> a -> b) -> b -> History k a -> b
forall k a b. (a -> b -> b) -> b -> History k a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => History k a -> a
$cproduct :: forall k a. Num a => History k a -> a
sum :: forall a. Num a => History k a -> a
$csum :: forall k a. Num a => History k a -> a
minimum :: forall a. Ord a => History k a -> a
$cminimum :: forall k a. Ord a => History k a -> a
maximum :: forall a. Ord a => History k a -> a
$cmaximum :: forall k a. Ord a => History k a -> a
elem :: forall a. Eq a => a -> History k a -> Bool
$celem :: forall k a. Eq a => a -> History k a -> Bool
length :: forall a. History k a -> Int
$clength :: forall k a. History k a -> Int
null :: forall a. History k a -> Bool
$cnull :: forall k a. History k a -> Bool
toList :: forall a. History k a -> [a]
$ctoList :: forall k a. History k a -> [a]
foldl1 :: forall a. (a -> a -> a) -> History k a -> a
$cfoldl1 :: forall k a. (a -> a -> a) -> History k a -> a
foldr1 :: forall a. (a -> a -> a) -> History k a -> a
$cfoldr1 :: forall k a. (a -> a -> a) -> History k a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> History k a -> b
$cfoldl' :: forall k b a. (b -> a -> b) -> b -> History k a -> b
foldl :: forall b a. (b -> a -> b) -> b -> History k a -> b
$cfoldl :: forall k b a. (b -> a -> b) -> b -> History k a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> History k a -> b
$cfoldr' :: forall k a b. (a -> b -> b) -> b -> History k a -> b
foldr :: forall a b. (a -> b -> b) -> b -> History k a -> b
$cfoldr :: forall k a b. (a -> b -> b) -> b -> History k a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> History k a -> m
$cfoldMap' :: forall k m a. Monoid m => (a -> m) -> History k a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> History k a -> m
$cfoldMap :: forall k m a. Monoid m => (a -> m) -> History k a -> m
fold :: forall m. Monoid m => History k m -> m
$cfold :: forall k m. Monoid m => History k m -> m
Foldable, forall k. Functor (History k)
forall k. Foldable (History k)
forall k (m :: * -> *) a.
Monad m =>
History k (m a) -> m (History k a)
forall k (f :: * -> *) a.
Applicative f =>
History k (f a) -> f (History k a)
forall k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> History k a -> m (History k b)
forall k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> History k a -> f (History k b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> History k a -> f (History k b)
sequence :: forall (m :: * -> *) a.
Monad m =>
History k (m a) -> m (History k a)
$csequence :: forall k (m :: * -> *) a.
Monad m =>
History k (m a) -> m (History k a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> History k a -> m (History k b)
$cmapM :: forall k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> History k a -> m (History k b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
History k (f a) -> f (History k a)
$csequenceA :: forall k (f :: * -> *) a.
Applicative f =>
History k (f a) -> f (History k a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> History k a -> f (History k b)
$ctraverse :: forall k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> History k a -> f (History k b)
Traversable)

instance (Eq  k, Eq  a) => Eq  (History k a) where == :: History k a -> History k a -> Bool
(==)    = forall a. Eq a => a -> a -> Bool
(==)    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall k a. History k a -> [(k, a)]
ledger
instance (Ord k, Ord a) => Ord (History k a) where compare :: History k a -> History k a -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall k a. History k a -> [(k, a)]
ledger

instance (Show k, Show a) => Show (History k a) where
  showsPrec :: Int -> History k a -> ShowS
showsPrec Int
d History k a
h
    = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec)
    forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"transcribe "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
app_precforall a. Num a => a -> a -> a
+Int
1) (forall k a. History k a -> [(k, a)]
ledger History k a
h)
    where app_prec :: Int
app_prec = Int
10

instance (Read k, Read a, Ord k) => Read (History k a) where
  readPrec :: ReadPrec (History k a)
readPrec = forall a. ReadPrec a -> ReadPrec a
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
app_prec forall a b. (a -> b) -> a -> b
$ do
    Ident String
"transcribe" <- ReadPrec Lexeme
lexP
    [(k, a)]
l <- forall a. ReadPrec a -> ReadPrec a
step forall a. Read a => ReadPrec a
readPrec
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => [(k, a)] -> History k a
transcribe [(k, a)]
l)
    where app_prec :: Int
app_prec = Int
10
  readListPrec :: ReadPrec [History k a]
readListPrec = forall a. Read a => ReadPrec [a]
readListPrecDefault


-- | /O(1)/. A history of nothing.
--
-- > mu origin := []
--
origin :: History k a
origin :: forall k a. History k a
origin = forall k a. IntMap (k, a) -> Map k Int -> History k a
History forall a. IntMap a
I.empty forall k a. Map k a
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 :: forall k a. Ord k => k -> a -> History k a -> History k a
event k
k a
a History{IntMap (k, a)
annals :: IntMap (k, a)
annals :: forall k a. History k a -> IntMap (k, a)
annals,Map k Int
recorded :: Map k Int
recorded :: forall k a. History k a -> Map k Int
recorded} = History
  { annals :: IntMap (k, a)
annals   = forall a. Int -> a -> IntMap a -> IntMap a
I.insert Int
ik (k
k, a
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Int -> IntMap a -> IntMap a
I.delete Maybe Int
mseen forall a b. (a -> b) -> a -> b
$ IntMap (k, a)
annals
  , recorded :: Map k Int
recorded = Map k Int
recorded'
  }
  where
    ik :: Int
ik = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (\((Int
i, (k, a)
_), IntMap (k, a)
_) -> forall a. Enum a => a -> a
pred Int
i) (forall a. IntMap a -> Maybe ((Int, a), IntMap a)
I.minViewWithKey IntMap (k, a)
annals)
    (Maybe Int
mseen, Map k Int
recorded') = forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
M.insertLookupWithKey (\k
_ Int
x Int
_ -> Int
x) k
k Int
ik Map k Int
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 :: forall k a. Ord k => k -> History k a -> History k a
erase k
k History{IntMap (k, a)
annals :: IntMap (k, a)
annals :: forall k a. History k a -> IntMap (k, a)
annals,Map k Int
recorded :: Map k Int
recorded :: forall k a. History k a -> Map k Int
recorded} = History
  { annals :: IntMap (k, a)
annals   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Int -> IntMap a -> IntMap a
I.delete Maybe Int
mseen IntMap (k, a)
annals
  , recorded :: Map k Int
recorded = Map k Int
recorded'
  }
  where (Maybe Int
mseen, Map k Int
recorded') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
M.updateLookupWithKey (\k
_ Int
_ -> forall a. Maybe a
Nothing) k
k Map k Int
recorded


-- | /O(log n)/. Recall an event.
recall :: Ord k => k -> History k a -> Maybe a
recall :: forall k a. Ord k => k -> History k a -> Maybe a
recall k
k History{IntMap (k, a)
annals :: IntMap (k, a)
annals :: forall k a. History k a -> IntMap (k, a)
annals,Map k Int
recorded :: Map k Int
recorded :: forall k a. History k a -> Map k Int
recorded} = do
  Int
ik     <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k Map k Int
recorded
  (k
_, a
a) <- forall a. Int -> IntMap a -> Maybe a
I.lookup Int
ik IntMap (k, a)
annals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | /O(n)/. Read history, starting with the modern day. @ledger@ is @mu@.
ledger :: History k a -> [(k, a)]
ledger :: forall k a. History k a -> [(k, a)]
ledger = forall a. IntMap a -> [a]
I.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. History k a -> IntMap (k, a)
annals

-- | /O(n * log n)/. Transcribe a ledger.
transcribe :: Ord k => [(k, a)] -> History k a
transcribe :: forall k a. Ord k => [(k, a)] -> History k a
transcribe = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> History k a -> History k a
event) forall k a. History k a
origin