{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Data.Rsv.RMMap
( RMMap(..)
, _handles
, _content
, Delete
, checkValidity
, checkHandle
, empty
, isEmpty
, (!)
, toList
, enqueue
, unqueue
, dequeue
)
where
import Control.Lens (Iso, anon, at, iso, makeLensesFor, (%%~),
(%~), (&))
import Data.Bifunctor (first)
import qualified Data.Foldable as F (toList)
import Data.Maybe (mapMaybe)
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import qualified Data.Map.Strict as M
import Data.Sequence (Seq (..))
import Data.Rsv.Common hiding (checkHandle)
import qualified Data.Rsv.Common as R (checkHandle)
type Entries a = Seq (RHandle, a)
data RMMap k a = RMMap {
handles :: !RHandles,
content :: !(M.Map k (Entries a))
} deriving (Show, Read, Generic, Eq)
makeLensesFor ((\x -> (x, "_" <> x)) <$> ["handles", "content"]) ''RMMap
data Delete k a = Delete !k !RHandle
deriving (Show, Read, Generic, Eq, Ord)
toPair
:: Iso
(RMMap k0 a0)
(RMMap k1 a1)
(RHandles, M.Map k0 (Entries a0))
(RHandles, M.Map k1 (Entries a1))
toPair = iso (\(RMMap x y) -> (x, y)) (uncurry RMMap)
checkValidity :: RMMap k a -> Maybe Text
checkValidity (RMMap handles' content') =
let res = flip mapMaybe (M.toList content') $ \(k, hh) -> do
if not (all (R.checkHandle handles' . fst) hh) then Just k else Nothing
in case res of
[] -> Nothing
e -> Just $ pack "some handles were reused in the input"
checkHandle :: RMMap k a -> Delete k a -> Bool
checkHandle (RMMap handles' _) (Delete _ h) = R.checkHandle handles' h
empty :: RMMap k a
empty = RMMap { handles = newHandles, content = M.empty }
isEmpty :: RMMap k a -> Bool
isEmpty sm = M.null m || all null m where m = content sm
(!) :: Ord k => RMMap k a -> k -> Seq a
m ! k = case M.lookup k $ content m of
Just l -> snd <$> l
Nothing -> mempty
toList :: RMMap k a -> [Delete k a]
toList (RMMap _ content') =
M.toList content' >>= \(k, hh) -> F.toList hh & fmap (Delete k . fst)
enqueue :: Ord k => (k, a) -> RMMap k a -> (Delete k a, RMMap k a)
enqueue i@(k, _) m = m & toPair %%~ withHandle enq i & first (Delete k)
where
enq
:: Ord k => (RHandle, (k, a)) -> M.Map k (Entries a) -> M.Map k (Entries a)
enq (h', (k', v')) m' = m' & at k' . anon mempty null %~ sEnqueue (h', v')
req :: (a -> b) -> (Maybe a, c) -> (Maybe b, c)
req = first . fmap
unqueue :: Ord k => Delete k a -> RMMap k a -> (Maybe (k, a), RMMap k a)
unqueue (Delete k idx) m =
m & _content . at k . anon mempty null %%~ sUnqueue idx & req (k, )
dequeue :: Ord k => k -> RMMap k a -> (Maybe (Delete k a, a), RMMap k a)
dequeue k m =
m & _content . at k . anon mempty null %%~ sDequeue & req (first (Delete k))