module Data.LensRef.Test
(
mkTests
, tests
) where
import Data.Maybe
import Control.Monad.State
import Control.Arrow ((***))
import Control.Lens
import Data.LensRef
import Data.LensRef.TestEnv
mkTests :: (MonadRegisterRun m, MonadRefWriter m, EffectM m ~ Prog (AsocT m), Monad n)
=> (m () -> n ())
-> n ()
mkTests runTest = do
newRefTest
writeRefsTest
extRefTest
joinTest
joinTest2
chainTest0
forkTest
forkTest2
chainTest
chainTest'
undoTest
undoTest2
undoTest3
where
newRefTest = runTest $ do
r <- newRef (3 :: Int)
r ==> 3
writeRefsTest = runTest $ do
r1 <- newRef (3 :: Int)
r2 <- newRef (13 :: Int)
r1 ==> 3
r2 ==> 13
writeRef r1 4
r1 ==> 4
r2 ==> 13
writeRef r2 0
r1 ==> 4
r2 ==> 0
extRefTest = runTest $ do
r <- newRef $ Just (3 :: Int)
q <- extRef r maybeLens (False, 0)
let q1 = _1 `lensMap` q
q2 = _2 `lensMap` q
r ==> Just 3
q ==> (True, 3)
writeRef r Nothing
r ==> Nothing
q ==> (False, 3)
q1 ==> False
writeRef q1 True
r ==> Just 3
writeRef q2 1
r ==> Just 1
joinTest = runTest $ do
r2 <- newRef (5 :: Int)
r1 <- newRef 3
rr <- newRef r1
r1 ==> 3
let r = join $ readRef rr
r ==> 3
writeRef r1 4
r ==> 4
writeRef rr r2
r ==> 5
writeRef r1 4
r ==> 5
writeRef r2 14
r ==> 14
joinTest2 = runTest $ do
r1 <- newRef (3 :: Int)
rr <- newRef r1
r2 <- newRef 5
writeRef rr r2
join (readRef rr) ==> 5
chainTest0 = runTest $ do
r <- newRef (1 :: Int)
q <- extRef r id 0
s <- extRef q id 0
r ==> 1
q ==> 1
s ==> 1
writeRef r 2
r ==> 2
q ==> 2
s ==> 2
writeRef q 3
r ==> 3
q ==> 3
s ==> 3
writeRef s 4
r ==> 4
q ==> 4
s ==> 4
forkTest = runTest $ do
r <- newRef (1 :: Int)
q <- extRef r id 0
s <- extRef r id 0
r ==> 1
q ==> 1
s ==> 1
writeRef r 2
r ==> 2
q ==> 2
s ==> 2
writeRef q 3
r ==> 3
q ==> 3
s ==> 3
writeRef s 4
r ==> 4
q ==> 4
s ==> 4
forkTest2 = runTest $ do
r <- newRef $ Just (1 :: Int)
q <- extRef r maybeLens (False, 0)
s <- extRef r maybeLens (False, 0)
r ==> Just 1
q ==> (True, 1)
s ==> (True, 1)
writeRef r $ Just 2
r ==> Just 2
q ==> (True, 2)
s ==> (True, 2)
writeRef r Nothing
r ==> Nothing
q ==> (False, 2)
s ==> (False, 2)
writeRef (_1 `lensMap` q) True
r ==> Just 2
q ==> (True, 2)
s ==> (True, 2)
writeRef (_2 `lensMap` q) 3
r ==> Just 3
q ==> (True, 3)
s ==> (True, 3)
writeRef (_1 `lensMap` q) False
r ==> Nothing
q ==> (False, 3)
s ==> (False, 3)
writeRef (_2 `lensMap` q) 4
r ==> Nothing
q ==> (False, 4)
s ==> (False, 3)
writeRef (_1 `lensMap` q) True
r ==> Just 4
q ==> (True, 4)
s ==> (True, 4)
writeRef q (False, 5)
r ==> Nothing
q ==> (False, 5)
s ==> (False, 4)
writeRef (_1 `lensMap` s) True
r ==> Just 4
q ==> (True, 4)
s ==> (True, 4)
chainTest = runTest $ do
r <- newRef $ Just Nothing
q <- extRef r maybeLens (False, Nothing)
s <- extRef (_2 `lensMap` q) maybeLens (False, 3 :: Int)
writeRef (_1 `lensMap` s) False
r ==> Just Nothing
q ==> (True, Nothing)
s ==> (False, 3)
writeRef (_1 `lensMap` q) False
r ==> Nothing
q ==> (False, Nothing)
s ==> (False, 3)
chainTest' = runTest $ do
r <- newRef $ Just $ Just (3 :: Int)
q <- extRef r maybeLens (False, Nothing)
s <- extRef (_2 `lensMap` q) maybeLens (False, 0 :: Int)
r ==> Just (Just 3)
q ==> (True, Just 3)
s ==> (True, 3)
writeRef (_1 `lensMap` s) False
r ==> Just Nothing
q ==> (True, Nothing)
s ==> (False, 3)
writeRef (_1 `lensMap` q) False
r ==> Nothing
q ==> (False, Nothing)
s ==> (False, 3)
writeRef (_1 `lensMap` s) True
r ==> Nothing
q ==> (False, Just 3)
s ==> (True, 3)
writeRef (_1 `lensMap` q) True
r ==> Just (Just 3)
q ==> (True, Just 3)
s ==> (True, 3)
undoTest = runTest $ do
r <- newRef (3 :: Int)
q <- extRef r (lens head $ flip (:)) []
writeRef r 4
q ==> [4, 3]
undoTest2 = runTest $ do
r <- newRef (3 :: Int)
q <- extRef r (lens head $ flip (:)) []
q ==> [3]
undoTest3 = runTest $ do
r <- newRef (3 :: Int)
(undo, redo) <- liftM (liftRefReader *** liftRefReader) $ undoTr (==) r
r ==> 3
redo === False
undo === False
writeRef r 4
r ==> 4
redo === False
undo === True
writeRef r 5
r ==> 5
redo === False
undo === True
push undo
r ==> 4
redo === True
undo === True
push undo
r ==> 3
redo === True
undo === False
push redo
r ==> 4
redo === True
undo === True
writeRef r 6
r ==> 6
redo === False
undo === True
where
push m = m >>= \x -> maybe (return ()) liftRefWriter x
m === t = m >>= \x -> isJust x ==? t
maybeLens :: Lens' (Bool, a) (Maybe a)
maybeLens = lens (\(b,a) -> if b then Just a else Nothing)
(\(_,a) x -> maybe (False, a) (\a' -> (True, a')) x)
undoTr
:: MonadRegister m =>
(a -> a -> Bool)
-> Ref m a
-> m ( RefReader m (Maybe (RefWriter m ()))
, RefReader m (Maybe (RefWriter m ()))
)
undoTr eq r = do
ku <- extRef r (undoLens eq) ([], [])
let try f = liftM (liftM (writeRefSimple ku) . f) $ readRef ku
return (try undo, try redo)
where
undo (x: xs@(_:_), ys) = Just (xs, x: ys)
undo _ = Nothing
redo (xs, y: ys) = Just (y: xs, ys)
redo _ = Nothing
undoLens :: (a -> a -> Bool) -> Lens' ([a],[a]) a
undoLens eq = lens get set where
get = head . fst
set (x' : xs, ys) x | eq x x' = (x: xs, ys)
set (xs, _) x = (x : xs, [])
tests :: (MonadRegisterRun m, EffectM m ~ Prog (AsocT m), Monad n, MonadRegister (Modifier m))
=> (forall a . (Eq a, Show a) => String -> m a -> Prog' (a, Prog' ()) -> n ())
-> n ()
tests runTest = do
runTest "trivial" (return ()) $ do
return ((), return ())
runTest "message" (message "Hello") $ do
message' "Hello"
return ((), return ())
runTest "listener" (listen 1 $ \s -> message $ "Hello " ++ s) $ do
message' "listener #0"
return $ (,) () $ do
send 1 "d"
message' "Hello d"
send 1 "f"
message' "Hello f"
runTest "listeners" (do
listen 1 $ \s -> message $ "Hello " ++ s
listen 2 $ \s -> message $ "Hi " ++ s
listen 3 $ \s -> do
message $ "H_ " ++ s
listen 4 $ \s' ->
message $ "H " ++ s'
) $ do
message' "listener #0"
message' "listener #1"
message' "listener #2"
return $ (,) () $ do
send 1 "d"
message' "Hello d"
send 1 "f"
message' "Hello f"
send 2 "f"
message' "Hi f"
send 3 "f"
message' "H_ f"
message' "listener #3"
send 4 "f"
message' "H f"
runTest "postponed0" (postponeModification $ message "hello") $ do
return $ (,) () $ do
message' "hello"
runTest "postponed" (do
r <- newRef "x"
_ <- onChangeSimple (readRef r) message
postponeModification $ writeRef r "x"
postponeModification $ writeRef r "y"
return ()
) $ do
message' "x"
return $ (,) () $ do
message' "y"
runTest "onChangeSimple" (do
r <- newRef "x"
listen 1 $ writeRef r
_ <- onChangeSimple (readRef r) message
return ()
) $ do
message' "listener #0"
message' "x"
return $ (,) () $ do
send 1 "x"
send 1 "y"
message' "y"
runTest "onChangeSimple + listener" (do
r1 <- newRef "x"
r2 <- newRef "y"
listen 1 $ writeRef r1
listen 2 $ writeRef r2
_ <- onChangeSimple (liftM2 (++) (readRef r1) (readRef r2)) message
return ()
) $ do
message' "listener #0"
message' "listener #1"
message' "xy"
return $ (,) () $ do
send 1 "x"
send 2 "y"
send 1 "y"
message' "yy"
send 2 "y"
send 2 "x"
message' "yx"
runTest "onChangeSimple + join" (do
r1 <- newRef "x"
r2 <- newRef "y"
rr <- newRef r1
listen 1 $ writeRef r1
listen 2 $ writeRef r2
listen 3 $ \i -> case i of
True -> writeRef rr r1
False -> writeRef rr r2
_ <- onChangeSimple (readRef $ join $ readRef rr) message
return ()
) $ do
message' "listener #0"
message' "listener #1"
message' "listener #2"
message' "x"
return $ (,) () $ do
send 1 "x"
send 2 "y"
send 1 "y"
message' "y"
send 2 "y"
send 2 "x"
send 3 False
message' "x"
send 1 "a"
send 2 "b"
message' "b"
runTest "" (do
r <- newRef (0 :: Int)
_ <- onChange (readRef r) $ \i -> case i of
0 -> return $ do
listen 1 $ \s -> do
when (s == "f") $ do
writeRef r 1
rv <- readRef r
message $ show rv
message $ "Hello " ++ s
1 -> do
listen 2 $ \s -> do
when (s == "g") $ writeRef r 0
message $ "Hi " ++ s
return $ return ()
return ()
) $ do
message' "listener #0"
return $ (,) () $ do
send 1 "d"
message' "Hello d"
send 1 "f"
message' "1"
message' "Hello f"
message' "Kill #0"
message' "listener #1"
send 1 "f"
error' "message is not received: 1 \"f\""
send 2 "f"
message' "Hi f"
send 2 "g"
message' "Hi g"
message' "listener #2"
send 2 "g"
error' "message is not received: 2 \"g\""
send 3 "f"
error' "message is not received: 3 \"f\""
send 1 "f"
message' "1"
message' "Hello f"
message' "Kill #2"
send 2 "f"
message' "Hi f"