{-# LANGUAGE CPP #-}

-- |

-- Module : Caching.ExpiringCacheMap.Utils.TestSequence

-- Copyright: (c) 2014 Edward L. Blake

-- License: BSD-style

-- Maintainer: Edward L. Blake <edwardlblake@gmail.com>

-- Stability: experimental

-- Portability: portable

--

-- TestSequence monad for testing caching behaviour.

--

-- > {-# LANGUAGE OverloadedStrings #-}

-- > 

-- > import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration)

-- > import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq

-- > 

-- > import qualified Data.ByteString.Char8 as BS

-- > 

-- > test = do

-- >   (TestSeq.TestSequenceState (_, events, _), return_value) <- TestSeq.runTestSequence test'

-- >   (putStrLn . show . reverse) events

-- >   return ()

-- >   where

-- >     test' = do

-- >       filecache <- newECMForM

-- >             (consistentDuration 100 -- Duration between access and expiry time of each item, no state needed.

-- >               (\state _id -> do number <- TestSeq.readNumber

-- >                                 return (state, number)))

-- >             (TestSeq.getCurrentTime >>= return)

-- >             12000 -- Time check frequency: (accumulator `mod` this_number) == 0.

-- >             (CacheWithLRUList 

-- >               6   -- Expected size of key-value map when removing elements.

-- >               6   -- Size of map when to remove items from key-value map.

-- >               12  -- Size of list when to compact

-- >               )

-- >             TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar

-- >       

-- >       -- Use lookupECM whenever the contents of "file1" is needed.

-- >       b <- lookupECM filecache ("file1" :: BS.ByteString)

-- >       TestSeq.haveNumber b

-- >       b <- lookupECM filecache "file1"

-- >       b <- lookupECM filecache "file2"

-- >       TestSeq.haveNumber b

-- >       return b

-- >

--

-- Evaluating the @test@ function results in a list of events.

--

-- >>> test

-- [GetVar 3,ReadNumber 4,GetTime 7,PutVar 11,HaveNumber 4,GetVar 14,PutVar 17,

--  GetVar 19,ReadNumber 20,GetTime 23,PutVar 27,HaveNumber 20]

-- 

-- In this example the history shows 2 time accesses (@GetTime 7@ and

-- @GetTime 23@) since the time check frequency number is a high value (12000),

-- but regardless the high value a time check is still requested again because

-- of the new key request for @"file2"@.

--

-- Changing the time frequency to 1 will alter the list of events with more

-- frequent time checks:

--

-- >>> test

-- [GetVar 3,ReadNumber 4,GetTime 7,PutVar 11,HaveNumber 4,GetVar 14,GetTime 15,

--  GetTime 18,PutVar 22,GetVar 24,ReadNumber 25,GetTime 28,PutVar 32,

--  HaveNumber 25]

--


module Caching.ExpiringCacheMap.Utils.TestSequence (
    runTestSequence,
    newTestSVar,
    enterTestSVar,
    readTestSVar,
    getCurrentTime,
    readNumber,
    haveNumber,
    TestSequenceEvents(..),
    TestSequenceState(..),
    TestSequence(..),
    TestSVar(..)
) where

#if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710)
import Control.Applicative (Applicative(..))
#endif
import Control.Monad (ap, liftM)
import Data.Word (Word32)

data TestSequenceEvents = 
  GetVar Word32 |
  PutVar Word32 |
  GetTime Word32 |
  ReadNumber Int |
  HaveNumber Int
  deriving (TestSequenceEvents -> TestSequenceEvents -> Bool
(TestSequenceEvents -> TestSequenceEvents -> Bool)
-> (TestSequenceEvents -> TestSequenceEvents -> Bool)
-> Eq TestSequenceEvents
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestSequenceEvents -> TestSequenceEvents -> Bool
$c/= :: TestSequenceEvents -> TestSequenceEvents -> Bool
== :: TestSequenceEvents -> TestSequenceEvents -> Bool
$c== :: TestSequenceEvents -> TestSequenceEvents -> Bool
Eq)

instance Show TestSequenceEvents where
  show :: TestSequenceEvents -> String
show (GetVar a :: Word32
a)     = "GetVar " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word32 -> String
forall a. Show a => a -> String
show Word32
a)
  show (PutVar a :: Word32
a)     = "PutVar " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word32 -> String
forall a. Show a => a -> String
show Word32
a)
  show (GetTime a :: Word32
a)    = "GetTime " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word32 -> String
forall a. Show a => a -> String
show Word32
a)
  show (ReadNumber a :: Int
a) = "ReadNumber " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
a)
  show (HaveNumber a :: Int
a) = "HaveNumber " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
a)


newtype TestSequenceState b =
  TestSequenceState (Word32, [TestSequenceEvents], Maybe b)
  
instance Show (TestSequenceState ct) where
  show :: TestSequenceState ct -> String
show (TestSequenceState (a :: Word32
a,b :: [TestSequenceEvents]
b,_)) =
    "TestSequenceState " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word32 -> String
forall a. Show a => a -> String
show Word32
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([TestSequenceEvents] -> String
forall a. Show a => a -> String
show [TestSequenceEvents]
b)

newtype TestSequence b a =
  TestSequence (TestSequenceState b -> (TestSequenceState b, a))

newtype TestSVar a = TestSVar a

-- For GHC 7.10

instance Functor (TestSequence a) where
  fmap :: (a -> b) -> TestSequence a a -> TestSequence a b
fmap = (a -> b) -> TestSequence a a -> TestSequence a b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
  
instance Applicative (TestSequence a) where
  pure :: a -> TestSequence a a
pure = a -> TestSequence a a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: TestSequence a (a -> b) -> TestSequence a a -> TestSequence a b
(<*>) = TestSequence a (a -> b) -> TestSequence a a -> TestSequence a b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (TestSequence a) where
  TestSequence fun :: TestSequenceState a -> (TestSequenceState a, a)
fun >>= :: TestSequence a a -> (a -> TestSequence a b) -> TestSequence a b
>>= k :: a -> TestSequence a b
k =
    (TestSequenceState a -> (TestSequenceState a, b))
-> TestSequence a b
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence
      (\state :: TestSequenceState a
state -> let (state' :: TestSequenceState a
state', ret :: a
ret) = (TestSequenceState a -> (TestSequenceState a, a)
fun TestSequenceState a
state)
                     TestSequence fun' :: TestSequenceState a -> (TestSequenceState a, b)
fun' = a -> TestSequence a b
k a
ret
                  in TestSequenceState a -> (TestSequenceState a, b)
fun' TestSequenceState a
state')
  return :: a -> TestSequence a a
return ret :: a
ret = 
    (TestSequenceState a -> (TestSequenceState a, a))
-> TestSequence a a
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, a))
 -> TestSequence a a)
-> (TestSequenceState a -> (TestSequenceState a, a))
-> TestSequence a a
forall a b. (a -> b) -> a -> b
$
      \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, testsvar :: Maybe a
testsvar)) ->
       ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1,[TestSequenceEvents]
hl, Maybe a
testsvar), a
ret)

runTestSequence :: Show a => TestSequence b a -> IO (TestSequenceState b, a)
runTestSequence :: TestSequence b a -> IO (TestSequenceState b, a)
runTestSequence f :: TestSequence b a
f = do
  let ret :: (TestSequenceState b, a)
ret = (TestSequenceState b -> (TestSequenceState b, a)
fun ((Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (0, [], Maybe b
forall a. Maybe a
Nothing)))
   in (TestSequenceState b, a) -> IO (TestSequenceState b, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TestSequenceState b, a)
ret
  where
    TestSequence fun :: TestSequenceState b -> (TestSequenceState b, a)
fun = ((TestSequenceState b -> (TestSequenceState b, ()))
-> TestSequence b ()
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence
      (\(TestSequenceState (t :: Word32
t, hl :: [TestSequenceEvents]
hl, testsvar :: Maybe b
testsvar)) ->
        ((Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
tWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, [TestSequenceEvents]
hl, Maybe b
testsvar), ()))) TestSequence b () -> TestSequence b a -> TestSequence b a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestSequence b a
f

newTestSVar :: a -> TestSequence a (TestSVar a)
newTestSVar :: a -> TestSequence a (TestSVar a)
newTestSVar var :: a
var = (TestSequenceState a -> (TestSequenceState a, TestSVar a))
-> TestSequence a (TestSVar a)
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, TestSVar a))
 -> TestSequence a (TestSVar a))
-> (TestSequenceState a -> (TestSequenceState a, TestSVar a))
-> TestSequence a (TestSVar a)
forall a b. (a -> b) -> a -> b
$
  \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, Nothing)) ->
   ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, [TestSequenceEvents]
hl, a -> Maybe a
forall a. a -> Maybe a
Just a
var), a -> TestSVar a
forall a. a -> TestSVar a
TestSVar a
var)

enterTestSVar :: TestSVar a -> (a -> TestSequence a (a,b)) -> TestSequence a b
enterTestSVar :: TestSVar a -> (a -> TestSequence a (a, b)) -> TestSequence a b
enterTestSVar testsvar :: TestSVar a
testsvar fun :: a -> TestSequence a (a, b)
fun = do
  a
teststate <- TestSVar a -> TestSequence a a
forall a. TestSVar a -> TestSequence a a
readTestSVar TestSVar a
testsvar
  (teststate' :: a
teststate',passalong :: b
passalong) <- a -> TestSequence a (a, b)
fun a
teststate
  TestSVar a -> a -> TestSequence a a
forall a. TestSVar a -> a -> TestSequence a a
putTestSVar TestSVar a
testsvar a
teststate'
  b -> TestSequence a b
forall (m :: * -> *) a. Monad m => a -> m a
return b
passalong

-- 'putTestSVar' is used along with 'readTestSVar' to implement enterTestSVar.

--

putTestSVar :: TestSVar a -> a -> TestSequence a a
putTestSVar :: TestSVar a -> a -> TestSequence a a
putTestSVar _testsvar :: TestSVar a
_testsvar testsvar' :: a
testsvar' = (TestSequenceState a -> (TestSequenceState a, a))
-> TestSequence a a
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, a))
 -> TestSequence a a)
-> (TestSequenceState a -> (TestSequenceState a, a))
-> TestSequence a a
forall a b. (a -> b) -> a -> b
$
  \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, testsvar :: Maybe a
testsvar)) ->
   ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, (Word32 -> TestSequenceEvents
PutVar Word32
timer) TestSequenceEvents -> [TestSequenceEvents] -> [TestSequenceEvents]
forall a. a -> [a] -> [a]
: [TestSequenceEvents]
hl, a -> Maybe a
forall a. a -> Maybe a
Just a
testsvar'),
      case Maybe a
testsvar of
        Nothing -> a
testsvar'
        Just testsvar'' :: a
testsvar'' -> a
testsvar'')

readTestSVar :: TestSVar a -> TestSequence a a
readTestSVar :: TestSVar a -> TestSequence a a
readTestSVar _testsvar :: TestSVar a
_testsvar = (TestSequenceState a -> (TestSequenceState a, a))
-> TestSequence a a
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, a))
 -> TestSequence a a)
-> (TestSequenceState a -> (TestSequenceState a, a))
-> TestSequence a a
forall a b. (a -> b) -> a -> b
$
  \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, Just testsvar :: a
testsvar)) ->
   ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, (Word32 -> TestSequenceEvents
GetVar Word32
timer) TestSequenceEvents -> [TestSequenceEvents] -> [TestSequenceEvents]
forall a. a -> [a] -> [a]
: [TestSequenceEvents]
hl, a -> Maybe a
forall a. a -> Maybe a
Just a
testsvar), a
testsvar)

getCurrentTime :: TestSequence a Int
getCurrentTime :: TestSequence a Int
getCurrentTime = (TestSequenceState a -> (TestSequenceState a, Int))
-> TestSequence a Int
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, Int))
 -> TestSequence a Int)
-> (TestSequenceState a -> (TestSequenceState a, Int))
-> TestSequence a Int
forall a b. (a -> b) -> a -> b
$
  \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, testsvar :: Maybe a
testsvar)) ->
   ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, (Word32 -> TestSequenceEvents
GetTime Word32
timer) TestSequenceEvents -> [TestSequenceEvents] -> [TestSequenceEvents]
forall a. a -> [a] -> [a]
: [TestSequenceEvents]
hl, Maybe a
testsvar), Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timer)

readNumber :: TestSequence a Int
readNumber :: TestSequence a Int
readNumber = (TestSequenceState a -> (TestSequenceState a, Int))
-> TestSequence a Int
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, Int))
 -> TestSequence a Int)
-> (TestSequenceState a -> (TestSequenceState a, Int))
-> TestSequence a Int
forall a b. (a -> b) -> a -> b
$
  \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, testsvar :: Maybe a
testsvar)) ->
    let number :: Int
number = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timer
     in ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, (Int -> TestSequenceEvents
ReadNumber Int
number) TestSequenceEvents -> [TestSequenceEvents] -> [TestSequenceEvents]
forall a. a -> [a] -> [a]
: [TestSequenceEvents]
hl, Maybe a
testsvar), Int
number)

haveNumber :: Int -> TestSequence a ()
haveNumber :: Int -> TestSequence a ()
haveNumber number :: Int
number = (TestSequenceState a -> (TestSequenceState a, ()))
-> TestSequence a ()
forall b a.
(TestSequenceState b -> (TestSequenceState b, a))
-> TestSequence b a
TestSequence ((TestSequenceState a -> (TestSequenceState a, ()))
 -> TestSequence a ())
-> (TestSequenceState a -> (TestSequenceState a, ()))
-> TestSequence a ()
forall a b. (a -> b) -> a -> b
$
  \(TestSequenceState (timer :: Word32
timer, hl :: [TestSequenceEvents]
hl, testsvar :: Maybe a
testsvar)) ->
   ((Word32, [TestSequenceEvents], Maybe a) -> TestSequenceState a
forall b.
(Word32, [TestSequenceEvents], Maybe b) -> TestSequenceState b
TestSequenceState (Word32
timerWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1, (Int -> TestSequenceEvents
HaveNumber Int
number) TestSequenceEvents -> [TestSequenceEvents] -> [TestSequenceEvents]
forall a. a -> [a] -> [a]
: [TestSequenceEvents]
hl, Maybe a
testsvar), ())