module Data.LRU (LRU, empty, null, size, hit, delete, toList, member, pop, last) where
import Prelude hiding (last, null)
import qualified Data.Map as Map
import Data.Maybe (fromJust, isNothing)
data (Ord a) => Item a = Item (Maybe a) (Maybe a)
data (Ord a) => LRU a = LRU (Maybe a) (Maybe a) (Map.Map a (Item a))
instance (Ord a, Show a) => Show (LRU a) where
show x = "LRU" ++ show (toList x)
empty :: (Ord a) => LRU a
empty = LRU Nothing Nothing Map.empty
null :: (Ord a) => LRU a -> Bool
null (LRU Nothing _ _) = True
null _ = False
size :: (Ord a) => LRU a -> Int
size (LRU _ _ map) = Map.size map
updatePrev :: (Ord a)
=> a
-> (Maybe a)
-> Map.Map a (Item a)
-> Map.Map a (Item a)
updatePrev toupdate newvalue =
Map.adjust (\(Item _ next) -> Item newvalue next) toupdate
updateNext :: (Ord a) => a -> (Maybe a) -> Map.Map a (Item a) -> Map.Map a (Item a)
updateNext toupdate newvalue =
Map.adjust (\(Item prev _) -> Item prev newvalue) toupdate
insert :: (Ord a) => a -> LRU a -> LRU a
insert value (LRU head tail map) = LRU newhead newtail newmap where
(newmap, newhead, newtail) =
case tail of
Nothing -> (Map.singleton value (Item Nothing Nothing), Just value, Just value)
(Just x) -> (Map.insert value (Item Nothing head) $
updatePrev (fromJust head) (Just value) map,
Just value, tail)
hit :: (Ord a) => a -> LRU a -> LRU a
hit value lru@(LRU head tail map) = r where
r = case Map.lookup value map of
Just (Item (Just prev) (Just next)) ->
LRU (Just value) tail $ updateHit $ updateNext prev (Just next) $
updatePrev next (Just prev) $ updatePrev (fromJust head) (Just value) map
Just (Item (Just prev) Nothing) ->
LRU (Just value) (Just prev) $ updateHit $ updateNext prev Nothing $ updatePrev (fromJust head) (Just value) map
Just (Item Nothing _) -> lru
Nothing -> insert value lru
updateHit = Map.insert value (Item Nothing head)
toList :: (Ord a) => LRU a -> [a]
toList (LRU head tail map) =
if Map.null map
then []
else (fromJust head) : (inner (fromJust head)) where
inner current = case next of
(Just value) -> value : (inner value)
Nothing -> []
where
Just (Item prev next) = Map.lookup current map
member :: (Ord a) => a -> LRU a -> Bool
member value (LRU _ _ map) = Map.member value map
delete :: (Ord a) => a -> LRU a -> LRU a
delete value lru@(LRU head tail map) =
case head of
Nothing -> lru
(Just x)
| x == value ->
let (Just (Item _ next), map') = Map.updateLookupWithKey (const $ const Nothing) value map in
LRU next (if isNothing next then Nothing else tail) map'
| otherwise ->
case tail of
(Just x)
| x == value ->
pop lru
| otherwise ->
LRU head tail $ updateNext (fromJust prev) next $ updatePrev (fromJust next) prev map' where
(Just (Item prev next), map') = Map.updateLookupWithKey (const $ const Nothing) value map
last :: (Ord a, Monad m) => LRU a -> m a
last (LRU _ tail _) = if isNothing tail then fail "Empty LRU" else return $ fromJust tail
pop :: (Ord a) => LRU a -> LRU a
pop (LRU head (Just tailvalue) map) = newlru where
newlru = if isOnlyElement
then empty
else LRU head newtail newmap
Just (Item prev _) = Map.lookup tailvalue map
isOnlyElement = isNothing prev
newtail = prev
newmap = updateNext (fromJust prev) Nothing $ Map.delete tailvalue map