Cache.hs

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-|
Module      : Data.Utils.Cache
Description : caching
Copyright   : (c) Lars Brünjes, 2016
License     : MIT
Maintainer  : brunjlar@gmail.com
Stability   : experimental
Portability : portable

This module defines simple size-limitted caches and utilities for working with them.
-}

module Data.Utils.Cache
    ( Cache
    , newCache
    , retrieveC
    ) where

import qualified Data.Map       as M
import           Data.MyPrelude
import qualified Data.Set       as S

-- | A @'Cache' m k v@ is a cache with keys of type @k@ and values of type @v@.
--   If an uncached key is requested, its value is retrieved using effects in monad @m@.
--
data Cache m k v = Cache
    { cMap      :: M.Map k v
    , cQueue    :: [k]
    , cGet      :: [k] -> m [v]
    , cCapacity :: Int
    }

-- | Creates a new cache with the given retrieval function and maximal cache capacity.
--
newCache :: ([k] -> m [v]) -> Int -> Cache m k v
newCache g c = Cache
    { cMap      = M.empty
    , cQueue    = []
    , cGet      = g
    , cCapacity = max c 0
    }

instance (Show k, Show v) => Show (Cache m k v) where

    show c = show (cMap c, cQueue c)

-- | Retrieves the values for the specified keys from the cache.
--   Uncached values will be retrieved and cached while respecting the maximal cache capacity
--   (old values will be dropped first).
--
retrieveC :: forall m k v. (Monad m, Ord k) => Cache m k v -> [k] -> m ([v], Cache m k v)
retrieveC c xs = do
    let (m, xs') = f
        (ys, zs) = splitAt (length xs') $ cQueue c
        n        = foldl' (flip M.delete) (cMap c) ys
        xs''     = toList xs'
    vs <- cGet c xs''
    let xvs = zip xs'' vs
        l   = max (cCapacity c) $ length ys
        m'  = foldl' (\m'' (x, v) -> M.insert x v m'') m xvs
        n'  = foldl' (\n'' (x, v) -> M.insert x v n'') n $ take l xvs
        zs' = zs ++ take l xs''
        c'  = c { cMap = n', cQueue = zs' }
        vs' = (m' M.!) <$> xs
    return (vs', c')

  where

    f :: (M.Map k v, S.Set k)
    f = foldl' f' (M.empty, S.empty) xs where
        f' (m, xs') x = case M.lookup x (cMap c) of
            Just y  -> (M.insert x y m,            xs')
            Nothing -> (             m, S.insert x xs')