network-control 0.1.4 → 0.1.5
raw patch · 5 files changed
+151/−31 lines, 5 files
Files
- Changelog.md +6/−0
- Network/Control/LRUCache.hs +113/−19
- network-control.cabal +2/−1
- test/Network/Control/FlowSpec.hs +8/−11
- test/Network/Control/LRUCacheSpec.hs +22/−0
Changelog.md view
@@ -1,5 +1,11 @@ # Revision history for network-control +## 0.1.5++* New API: `lookup'` adjusts the target priority.+* New API: `LRUCacheRef` stuffs+* `insert` rebuilds PSQ when reached the limit.+ ## 0.1.4 * Using Integer instead of Int in LRUCache.
Network/Control/LRUCache.hs view
@@ -7,46 +7,140 @@ insert, delete, lookup,-) where+ lookup', -import Prelude hiding (lookup)+ -- * IO+ LRUCacheRef,+ newLRUCacheRef,+ cached,+ cached', + -- * Internal+ empty',+) where++import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Int (Int64) import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as PSQ+import Prelude hiding (lookup) -type Priority = Integer+---------------------------------------------------------------- +type Priority = Int64+ -- | Sized cache based on least recently used. data LRUCache k v = LRUCache { lcLimit :: Int- , lcSize :: Int+ -- ^ The maximum number of elements in the queue , lcTick :: Priority+ -- ^ The next logical time , lcQueue :: OrdPSQ k Priority v }+ deriving (Eq, Show) --- | Empty 'LRUCache'.+----------------------------------------------------------------++-- | Empty 'LRUCache'. /O(1)/ empty :: Int -- ^ The size of 'LRUCache'. -> LRUCache k v-empty lim = LRUCache lim 0 0 PSQ.empty+empty capacity+ | capacity < 1 = error "LRUCache.empty: capacity < 1"+ | otherwise =+ LRUCache+ { lcLimit = capacity+ , lcTick = 0+ , lcQueue = PSQ.empty+ } --- | Inserting.+-- | Empty 'LRUCache'. /O(1)/+empty'+ :: Int+ -- ^ The size of 'LRUCache'.+ -> Int64+ -- ^ Counter+ -> LRUCache k v+empty' capacity tick =+ LRUCache+ { lcLimit = capacity+ , lcTick = tick+ , lcQueue = PSQ.empty+ }++----------------------------------------------------------------++trim :: Ord k => LRUCache k v -> LRUCache k v+trim c@LRUCache{..}+ | lcTick == maxBound =+ let siz = fromIntegral $ PSQ.size lcQueue+ diff = (maxBound :: Priority) - siz+ psq = PSQ.unsafeMapMonotonic (\_ p v -> (p - diff, v)) lcQueue+ in LRUCache+ { lcLimit = lcLimit+ , lcTick = siz+ , lcQueue = psq+ }+ | PSQ.size lcQueue > lcLimit = c{lcQueue = PSQ.deleteMin lcQueue}+ | otherwise = c++----------------------------------------------------------------++-- | Inserting. /O(log n)/ insert :: Ord k => k -> v -> LRUCache k v -> LRUCache k v-insert k v c@LRUCache{..}- | lcSize == lcLimit =- let q = PSQ.insert k lcTick v $ PSQ.deleteMin lcQueue- in c{lcTick = lcTick + 1, lcQueue = q}- | otherwise =- let q = PSQ.insert k lcTick v lcQueue- in c{lcTick = lcTick + 1, lcQueue = q, lcSize = lcSize + 1}+insert key val c@LRUCache{..} = trim c'+ where+ queue = PSQ.insert key lcTick val lcQueue+ c' = c{lcTick = lcTick + 1, lcQueue = queue} --- | Deleting.+----------------------------------------------------------------++-- | Deleting. /O(log n)/ delete :: Ord k => k -> LRUCache k v -> LRUCache k v-delete k c@LRUCache{..} =- let q = PSQ.delete k lcQueue- in c{lcQueue = q, lcSize = lcSize - 1}+delete k c@LRUCache{..} = c{lcQueue = q}+ where+ q = PSQ.delete k lcQueue --- | Looking up.+----------------------------------------------------------------++-- | Looking up. /O(log n)/ lookup :: Ord k => k -> LRUCache k v -> Maybe v lookup k LRUCache{..} = snd <$> PSQ.lookup k lcQueue++-- | Looking up and changing priority. /O(log n)/+lookup' :: Ord k => k -> LRUCache k v -> Maybe (v, LRUCache k v)+lookup' k c@LRUCache{..} = case PSQ.alter lookupAndBump k lcQueue of+ (Nothing, _) -> Nothing+ (Just v, q) ->+ let c' = trim $ c{lcTick = lcTick + 1, lcQueue = q}+ in Just (v, c')+ where+ lookupAndBump Nothing = (Nothing, Nothing)+ -- setting its priority to lcTick+ lookupAndBump (Just (_p, v)) = (Just v, Just (lcTick, v))++----------------------------------------------------------------++newtype LRUCacheRef k v = LRUCacheRef (IORef (LRUCache k v))++newLRUCacheRef :: Int -> IO (LRUCacheRef k v)+newLRUCacheRef capacity = LRUCacheRef <$> newIORef (empty capacity)++cached' :: Ord k => LRUCacheRef k v -> k -> IO (Maybe v)+cached' (LRUCacheRef ref) k = do+ atomicModifyIORef' ref $ \c -> case lookup' k c of+ Nothing -> (c, Nothing)+ Just (v, c') -> (c', Just v)++cached :: Ord k => LRUCacheRef k v -> k -> IO v -> IO (v, Bool)+cached (LRUCacheRef ref) k io = do+ lookupRes <- atomicModifyIORef' ref $ \c -> case lookup' k c of+ Nothing -> (c, Nothing)+ Just (v, c') -> (c', Just v)+ case lookupRes of+ Just v -> return (v, True)+ Nothing -> do+ v <- io+ atomicModifyIORef' ref $ \c -> (insert k v c, ())+ return (v, False)
network-control.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: network-control-version: 0.1.4+version: 0.1.5 license: BSD-3-Clause license-file: LICENSE maintainer: kazu@iij.ad.jp@@ -33,6 +33,7 @@ hs-source-dirs: test other-modules: Network.Control.FlowSpec+ Network.Control.LRUCacheSpec default-language: Haskell2010 default-extensions: Strict StrictData
test/Network/Control/FlowSpec.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns #-} -module Network.Control.FlowSpec where+module Network.Control.FlowSpec (spec) where import Data.List import Data.Text.Lazy (unpack)@@ -104,7 +101,7 @@ assertStep :: RxFlow -> [(Int, Step OpWithResult, RxFlow)] -> Property assertStep _ [] = property True assertStep oldFlow ((ix, step, newFlow) : steps) =- (counterexample ("step #" <> show ix) check) .&. assertStep newFlow steps+ counterexample ("step #" <> show ix) check .&. assertStep newFlow steps where check :: Expectation check = case step of@@ -141,10 +138,9 @@ newFlow `shouldSatisfy` \flow -> rxfLimit flow > rxfConsumed flow -- Condition (c)- limitDelta `shouldSatisfy` \mUpd ->- case mUpd of- Nothing -> True- Just upd -> upd >= rxfBufSize newFlow `div` 8+ limitDelta `shouldSatisfy` \case+ Nothing -> True+ Just upd -> upd >= rxfBufSize newFlow `div` 8 Step (ReceiveWithResult isAcceptable) arg -> do newFlow `shouldBe` if isAcceptable@@ -159,5 +155,6 @@ spec :: Spec spec = do- focus . prop "state transition graph checks out" $- \trace -> counterexample (unpack $ pShowNoColor trace) (assertTrace trace)+ describe "Flow" $ do+ prop "state transition graph checks out" $ \trace ->+ counterexample (unpack $ pShowNoColor trace) (assertTrace trace)
+ test/Network/Control/LRUCacheSpec.hs view
@@ -0,0 +1,22 @@+module Network.Control.LRUCacheSpec (spec) where++import Data.Maybe+import Network.Control+import qualified Network.Control as LRU+import Test.Hspec++spec :: Spec+spec = do+ describe "LRUCache" $ do+ it "can keep entry if looked up" $ do+ let cache = insert 'b' "bar" $ insert 'a' "foo" $ empty 2+ (v, cache') = fromJust $ LRU.lookup' 'a' cache+ v `shouldBe` "foo"+ let cache'' = insert 'c' "baz" cache'+ fst <$> LRU.lookup' 'a' cache'' `shouldBe` Just "foo"+ fst <$> LRU.lookup' 'b' cache'' `shouldBe` Nothing+ fst <$> LRU.lookup' 'c' cache'' `shouldBe` Just "baz"+ it "can rebuild PSQ when reached the limit" $ do+ let cache = insert 'b' "bar" $ insert 'a' "foo" $ empty' 2 (maxBound - 2)+ show cache+ `shouldBe` "LRUCache {lcLimit = 2, lcTick = 2, lcQueue = Winner (E 'a' 0 \"foo\") (RLoser 1 (E 'b' 1 \"bar\") Start 'a' Start) 'b'}"