lrucaching-haxl (empty) → 0.1.0.0

raw patch · 3 files changed

+138/−0 lines, 3 filesdep +basedep +hashabledep +haxl

Dependencies added: base, hashable, haxl, lrucaching, psqueues

Files

• LICENSE +30/−0
• lrucaching-haxl.cabal +29/−0
• src/Data/LruCache/Haxl.hs +79/−0

@@ -0,0 +1,30 @@+Copyright Li Meng Jun (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Li Meng Jun nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,29 @@+name:                lrucaching-haxl+version:             0.1.0.0+synopsis:            Combine lrucaching and haxl.+description:         Combine lrucaching and haxl. easy use on haxl+homepage:            https://github.com/Lupino/yuntan-common/tree/lrucaching-haxl#readme+license:             BSD3+license-file:        LICENSE+author:              Li Meng Jun+maintainer:          lmjubuntu@gmail.com+copyright:           MIT+category:            Data,LruCache,Concurrency+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10+++library+  hs-source-dirs:      src+  exposed-modules:     Data.LruCache.Haxl+  build-depends:       base >= 4.7 && < 5+                     , haxl+                     , hashable+                     , lrucaching+                     , psqueues+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/Lupino/yuntan-common

@@ -0,0 +1,79 @@+module Data.LruCache.Haxl+  ( LruHandle (..)+  , newLruHandle+  , cached'+  , cached+  , remove+  , updateLruHandle+  ) where+++import           Data.Hashable          (Hashable (..))+import           Haxl.Core              (GenHaxl, env, userEnv)+import           Haxl.Core.Monad        (unsafeLiftIO)++import           Data.HashPSQ           (delete, member)+import           Data.IORef             (atomicModifyIORef')+import           Data.LruCache          (empty, insert, lookup)+import           Data.LruCache.Internal (LruCache (..))+import           Data.LruCache.IO       (LruHandle (..), newLruHandle)+import           Prelude                hiding (lookup)++-- LruCache+doLookup :: (Hashable k, Ord k) => k -> LruCache k v -> (LruCache k v, Maybe v)+doLookup k c = case lookup k c of+                 Nothing      -> (c, Nothing)+                 Just (v, c') -> (c', Just v)++doInsert :: (Hashable k, Ord k) => k -> v -> a -> LruCache k v -> (LruCache k v, a)+doInsert k v v0 c = (insert k v c, v0)++-- | Return the cached result of the action or, in the case of a cache+-- miss, execute the action and insert it in the cache.+cached :: (Hashable k, Ord k) => (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)+cached lru k io = do+  h <- lru <$> env userEnv+  go h k io++  where go :: (Hashable k, Ord k) => Maybe (LruHandle k v) -> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)+        go Nothing _ io0 = io0+        go (Just (LruHandle ref)) k0 io0 = do+          res <- unsafeLiftIO $ atomicModifyIORef' ref $ doLookup k0+          case res of+            Just v -> return (Just v)+            Nothing -> do+              v <- io0+              case v of+                Nothing -> return Nothing+                Just v0 -> unsafeLiftIO $ atomicModifyIORef' ref $ doInsert k0 v0 v++cached' :: (Hashable k, Ord k) => (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w v -> GenHaxl u w v+cached' lru k io = do+  h <- lru <$> env userEnv+  go h k io+  where go :: (Hashable k, Ord k) => Maybe (LruHandle k v) -> k -> GenHaxl u w v -> GenHaxl u w v+        go Nothing _ io0 = io0+        go (Just (LruHandle ref)) k0 io0 = do+          res <- unsafeLiftIO $ atomicModifyIORef' ref $ doLookup k0+          case res of+            Just v -> return v+            Nothing -> do+              v <- io0+              unsafeLiftIO $ atomicModifyIORef' ref $ doInsert k0 v v++remove :: (Hashable k, Ord k) => (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w ()+remove lru k = do+  h <- lru <$> env userEnv+  case h of+    Nothing -> return ()+    Just (LruHandle ref) ->+      unsafeLiftIO $ atomicModifyIORef' ref $ \c -> do+        let queue = lruQueue c+            size  = lruSize c++        if member k queue then (c { lruSize = size - 1, lruQueue = delete k queue }, ())+                else (c, ())++updateLruHandle :: (Hashable k, Ord k) => LruHandle k v -> Int -> IO ()+updateLruHandle (LruHandle ref) size =+  atomicModifyIORef' ref $ const (empty size, ())