caching utility

Author: brunjlar

neural.cabal

@@ -58,6 +58,7 @@ library
                      , Data.Utils
                      , Data.Utils.Analytic
                      , Data.Utils.Arrow
+                     , Data.Utils.Cache
                      , Data.Utils.List
                      , Data.Utils.Matrix
                      , Data.Utils.Pipes
@@ -72,6 +73,7 @@ library
                      , ad
                      , array
                      , bytestring
+                     , containers
                      , deepseq
                      , directory
                      , filepath
@@ -104,7 +106,8 @@ test-suite neural-test
                      , hspec
                      , MonadRandom
                      , neural
-  other-modules:       Utils.MatrixSpec
+  other-modules:       Utils.CacheSpec
+                     , Utils.MatrixSpec
                      , Utils.VectorSpec
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math
   default-language:    Haskell2010

src/Data/Utils.hs

@@ -15,6 +15,7 @@ This module reexports various utility modules for convenience.
 module Data.Utils
     ( module Data.Utils.Analytic
     , module Data.Utils.Arrow
+    , module Data.Utils.Cache
     , module Data.Utils.Matrix
     , module Data.Utils.Pipes
     , module Data.Utils.Random
@@ -26,6 +27,7 @@ module Data.Utils
 
 import Data.Utils.Analytic
 import Data.Utils.Arrow
+import Data.Utils.Cache
 import Data.Utils.Matrix
 import Data.Utils.Pipes
 import Data.Utils.Random

src/Data/Utils/Cache.hs

@@ -0,0 +1,78 @@
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE DeriveFunctor #-}
+{-# 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')

src/Numeric/Neural/Normalization.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK show-extensions #-}
+
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}

test/Utils/CacheSpec.hs

@@ -0,0 +1,36 @@
+module Utils.CacheSpec (spec) where
+
+import Test.Hspec
+import Data.MyPrelude
+import Data.Utils
+
+spec :: Spec
+spec = cacheSpec
+
+cacheSpec :: Spec
+cacheSpec = describe "retrieveC" $ do
+
+    it "should retrieve uncached elements" $
+        let w = do
+                    (xs, _) <- retrieveC mkCache [1, 2, 3]
+                    return xs
+        in  runWriter w `shouldBe` ([1, 2, 3], [1, 2, 3])
+
+    it "should use the cache if possible" $
+        let w = do
+                    (_,  c) <- retrieveC mkCache [1, 2, 3]
+                    (xs, _) <- retrieveC c       [3, 3, 1, 4]
+                    return xs
+        in  runWriter w `shouldBe` ([3, 3, 1, 4], [1, 2, 3, 4])
+
+    it "should respect the cache capacity" $
+        let w = do
+                    (_,  c ) <- retrieveC mkCache [1, 2, 3]
+                    (_,  c') <- retrieveC c       [3, 3, 1, 4]
+                    (xs, _ ) <- retrieveC c'      [4, 1]
+                    return xs
+        in  runWriter w `shouldBe` ([4, 1], [1, 2, 3, 4, 1])
+
+mkCache :: Cache (Writer [Int]) Int Int
+mkCache = newCache f 3 where
+    f xs = tell xs >> return xs