zifter-0.0.1.2: test/Zifter/ZiftSpec.hs
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
module Zifter.ZiftSpec
( spec
) where
import Test.Hspec
import Test.QuickCheck
import Test.Validity
import Path.IO
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import Data.Foldable
import Data.GenValidity.Path ()
import Zifter.OptParse.Gen ()
import Zifter.OptParse.Types
import Zifter.Zift
import Zifter.Zift.Gen ()
{-# ANN module "HLint: ignore Reduce duplication" #-}
spec :: Spec
spec = do
describe "ZiftOutput" $ eqSpec @ZiftOutput
describe "ZiftResult" $ do
eqSpec @(ZiftResult Int)
genValiditySpec @(ZiftResult Double)
functorSpec @ZiftResult
applicativeSpec @ZiftResult
monoidSpec @(ZiftResult String)
monadSpec @ZiftResult
describe "Zift" $ do
describe "Monoid Zift" $ do
describe "mempty" $
it "succeeds with empty buffer" $
forAll genUnchecked $ \sets -> do
let zf = mempty :: Zift ()
(zr, zs) <- runZiftTest sets zf
zr `shouldBe` ZiftSuccess ()
zs `shouldBe` ZiftState {bufferedOutput = []}
describe "mappend" $
it
"succeeds with empty buffers but with the output in the channel" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \zo1 ->
forAll genUnchecked $ \zo2 -> do
let zf1 =
Zift $ \_ _ ->
pure
( ZiftSuccess ()
, ZiftState {bufferedOutput = [zo1]})
let zf2 =
Zift $ \_ _ ->
pure
( ZiftSuccess ()
, ZiftState {bufferedOutput = [zo2]})
let zf = zf1 `mappend` zf2
pchan <- atomically newTChan
(zr, zs) <- runZiftTestWithChan pchan sets zf
zr `shouldBe` ZiftSuccess ()
zs `shouldBe` ZiftState {bufferedOutput = []}
atomically (readTChan pchan) `shouldReturn` zo1
atomically (readTChan pchan) `shouldReturn` zo2
describe "Functor Zift" $
describe "fmap" $
it "it succeeds with a flushed buffer" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state -> do
let zf =
fmap (+ 1) $
Zift $ \_ st -> pure (ZiftSuccess (0 :: Int), st)
pchan <- atomically newTChan
(zr, zs) <- runZiftTestWith state pchan sets zf
zr `shouldBe` ZiftSuccess 1
zs `shouldBe` ZiftState {bufferedOutput = []}
buffer <- readAllFrom pchan
buffer `shouldBe` reverse (bufferedOutput state)
describe "Applicative Zift" $ do
describe "pure" $
it "succeeds with the same state" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state -> do
let zf = pure () :: Zift ()
(zr, zs) <- runZiftTestWithState state sets zf
zr `shouldBe` ZiftSuccess ()
zs `shouldBe` state
describe "<*>" $ do
it
"succeeds with a linear flushed buffer if used at the top-level" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state ->
forAll genUnchecked $ \st1 ->
forAll genUnchecked $ \st2 -> do
let zf1 =
Zift $ \_ st ->
pure
( ZiftSuccess (+ 1)
, st `mappend` st1)
let zf2 =
Zift $ \_ st ->
pure
( ZiftSuccess (1 :: Int)
, st `mappend` st2)
let zf = zf1 <*> zf2
pchan <- atomically newTChan
(zr, zs) <-
runZiftTestWith state pchan sets zf
zr `shouldBe` ZiftSuccess 2
zs `shouldBe`
ZiftState {bufferedOutput = []}
buffer <- readAllFrom pchan
buffer `shouldBe`
reverse
(bufferedOutput st2 ++
bufferedOutput st1 ++
bufferedOutput state)
it "fails immediately if the first of the two actions failed" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state ->
forAll genUnchecked $ \st1 ->
forAll genUnchecked $ \failedMessage -> do
let zf1 =
Zift $ \_ st ->
pure
( ZiftFailed failedMessage :: ZiftResult (Int -> String)
, st `mappend` st1)
let zf2 = do
liftIO $
threadDelay $ 5 * 1000 * 1000
pure 1 :: Zift Int
let zf = zf1 <*> zf2
pchan <- atomically newTChan
(zr, zs) <-
runZiftTestWith state pchan sets zf
zr `shouldBe`
(ZiftFailed failedMessage :: ZiftResult String)
zs `shouldBe`
ZiftState
{ bufferedOutput =
bufferedOutput st1 ++
bufferedOutput state
}
buffer <- readAllFrom pchan
buffer `shouldBe` []
it "fails immediately if the second of the two actions failed" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state ->
forAll genUnchecked $ \st2 ->
forAll genUnchecked $ \failedMessage -> do
let zf1 = do
liftIO $
threadDelay $ 5 * 1000 * 1000
pure show :: Zift (Int -> String)
let zf2 =
Zift $ \_ st ->
pure
( ZiftFailed failedMessage :: ZiftResult Int
, st `mappend` st2)
let zf = zf1 <*> zf2
pchan <- atomically newTChan
(zr, zs) <-
runZiftTestWith state pchan sets zf
zr `shouldBe`
(ZiftFailed failedMessage :: ZiftResult String)
zs `shouldBe`
ZiftState
{ bufferedOutput =
bufferedOutput st2 ++
bufferedOutput state
}
buffer <- readAllFrom pchan
buffer `shouldBe` []
it
"Orders the messages correctly when they are printed in a for_ loop" $
forAll genUnchecked $ \ls ->
forAll genUnchecked $ \rl ->
forAll genUnchecked $ \sets -> do
let zf =
withRecursionList rl $
for_ ls addZiftOutput
pchan <- atomically newTChan
(zr, zs) <- runZiftTestWithChan pchan sets zf
zr `shouldBe` ZiftSuccess ()
buffer <- readAllFrom pchan
(buffer ++ reverse (bufferedOutput zs)) `shouldBe`
ls
describe "Monad Zift" $
describe ">>=" $ do
it "succeeds with a flushed buffer after the first output" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state ->
forAll genUnchecked $ \st1 ->
forAll genUnchecked $ \st2 -> do
let zf1 =
Zift $ \_ st ->
pure
( ZiftSuccess (2 :: Int)
, st `mappend` st1)
let zf2 n =
Zift $ \_ st ->
pure
( ZiftSuccess (n + 1)
, st `mappend` st2)
let zf = zf1 >>= zf2
pchan <- atomically newTChan
(zr, zs) <-
runZiftTestWith state pchan sets zf
zr `shouldBe` ZiftSuccess 3
zs `shouldBe` st2
buffer <- readAllFrom pchan
buffer `shouldBe`
reverse
(bufferedOutput st1 ++
bufferedOutput state)
it "fails if the first part failed" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state ->
forAll genUnchecked $ \st1 ->
forAll genUnchecked $ \st2 ->
forAll genUnchecked $ \failMsg -> do
let zf1 =
Zift $ \_ st ->
pure
( ZiftFailed failMsg :: ZiftResult Int
, st `mappend` st1)
let zf2 n =
Zift $ \_ st ->
pure
( ZiftSuccess (n + 1)
, st `mappend` st2)
let zf = zf1 >>= zf2
pchan <- atomically newTChan
(zr, zs) <-
runZiftTestWith state pchan sets zf
zr `shouldBe` ZiftFailed failMsg
zs `shouldBe` mempty
buffer <- readAllFrom pchan
buffer `shouldBe`
reverse
(bufferedOutput st1 ++
bufferedOutput state)
it "fails if the second part failed" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state ->
forAll genUnchecked $ \st1 ->
forAll genUnchecked $ \st2 ->
forAll genUnchecked $ \failMsg -> do
let zf1 =
Zift $ \_ st ->
pure
( ZiftSuccess (1 :: Int)
, st `mappend` st1)
let zf2 _ =
Zift $ \_ st ->
pure
( ZiftFailed failMsg :: ZiftResult (Int -> Int)
, st `mappend` st2)
let zf = zf1 >>= zf2
pchan <- atomically newTChan
(zr, zs) <-
runZiftTestWith state pchan sets zf
case zr of
ZiftSuccess _ ->
expectationFailure
"should have failed."
ZiftFailed msg -> do
msg `shouldBe` failMsg
zs `shouldBe` st2
buffer <- readAllFrom pchan
buffer `shouldBe`
reverse
(bufferedOutput st1 ++
bufferedOutput state)
it
"Orders the messages correctly when they are printed in a forM_ loop at any depth" $
forAll genUnchecked $ \ls ->
forAll genUnchecked $ \rl ->
forAll genUnchecked $ \sets -> do
let zf = forM_ ls addZiftOutput
zf' = withRecursionList rl zf
pchan <- atomically newTChan
(zr, zs) <- runZiftTestWithChan pchan sets zf'
zr `shouldBe` ZiftSuccess ()
buffer <- readAllFrom pchan
(buffer ++ reverse (bufferedOutput zs)) `shouldBe`
ls
it "Orders the messages in this do-notation correctly" $
forAll genUnchecked $ \(m1, m2, m3) ->
forAll genUnchecked $ \rl ->
forAll genUnchecked $ \sets -> do
let zf =
withRecursionList rl $ do
addZiftOutput m1
addZiftOutput m2
addZiftOutput m3
pchan <- atomically newTChan
(zr, zs) <- runZiftTestWithChan pchan sets zf
zr `shouldBe` ZiftSuccess ()
buffer <- readAllFrom pchan
(buffer ++ reverse (bufferedOutput zs)) `shouldBe`
[m1, m2, m3]
describe "MonadFail Zift" $ do
describe "fail" $
it "just results in a ZiftFailed" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state -> do
let s = "Test"
let zf = fail s :: Zift ()
(zr, zs) <- runZiftTestWithState state sets zf
zr `shouldBe` ZiftFailed s
zs `shouldBe` state
describe "liftIO . fail" $
it "just returns ZiftFailed" $
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \state -> do
let s = "Test"
let zf = liftIO $ fail s :: Zift ()
(zr, zs) <- runZiftTestWithState state sets zf
zr `shouldBe` ZiftFailed ("user error (" ++ s ++ ")")
zs `shouldBe` state
describe "tryFlushZiftBuffer" $ do
it "does not do anything if there recursion list is not flushable" $
forAll genUnchecked $ \state ->
forAllCtx $ \ctx ->
if flushable $ recursionList ctx
then pure () -- Not testing this part now.
else do
state' <- tryFlushZiftBuffer ctx state
state' `shouldBe` state
it
"flushes the entire buffer in the correct order, if the recursion list is empty" $
forAll genUnchecked $ \state ->
forAllCtx $ \ctx ->
if flushable $ recursionList ctx
then do
state' <- tryFlushZiftBuffer ctx state
state' `shouldBe` state {bufferedOutput = []}
res <- readAllFrom $ printChan ctx
res `shouldBe` reverse (bufferedOutput state)
else pure ()
forAllCtx :: Testable (IO b) => (ZiftContext -> IO b) -> Property
forAllCtx func =
forAll genUnchecked $ \rd ->
forAll genUnchecked $ \sets ->
forAll genUnchecked $ \rl ->
forAll genUnchecked $ \td -> do
pchan <- atomically newTChan
let zc =
ZiftContext
{ rootdir = rd
, tmpdir = td
, settings = sets
, printChan = pchan
, recursionList = rl
}
func zc
runZiftTest :: Settings -> Zift a -> IO (ZiftResult a, ZiftState)
runZiftTest sets func = do
pchan <- atomically newTChan
runZiftTestWithChan pchan sets func
runZiftTestWithChan ::
TChan ZiftOutput -> Settings -> Zift a -> IO (ZiftResult a, ZiftState)
runZiftTestWithChan = runZiftTestWith ZiftState {bufferedOutput = []}
runZiftTestWithState ::
ZiftState -> Settings -> Zift a -> IO (ZiftResult a, ZiftState)
runZiftTestWithState state sets func = do
pchan <- atomically newTChan
runZiftTestWith state pchan sets func
runZiftTestWith ::
ZiftState
-> TChan ZiftOutput
-> Settings
-> Zift a
-> IO (ZiftResult a, ZiftState)
runZiftTestWith zs pchan sets func = do
rd <- getCurrentDir
td <- resolveDir rd ".zifter"
let zc =
ZiftContext
{ rootdir = rd
, tmpdir = td
, settings = sets
, printChan = pchan
, recursionList = []
}
zift func zc zs
readAllFrom :: TChan a -> IO [a]
readAllFrom chan = do
mr <- atomically $ tryReadTChan chan
case mr of
Nothing -> pure []
Just r -> do
rest <- readAllFrom chan
pure (r : rest)
withRecursionList :: [LMR] -> Zift a -> Zift a
withRecursionList rl zf =
zf {zift = \zc zs -> zift zf (zc {recursionList = rl}) zs}