ZiftSpec.hs

{-# LANGUAGE TypeApplications #-}

module Zifter.ZiftSpec
    ( spec
    ) where

import Test.Hspec
import Test.QuickCheck
import Test.Validity

import Path.IO

import Control.Concurrent.STM

import Zifter.OptParse.Gen ()
import Zifter.OptParse.Types
import Zifter.Zift
import Zifter.Zift.Gen ()

spec :: Spec
spec = do
    describe "ZiftOutput" $ eqSpec @ZiftOutput
    describe "ZiftResult" $ do
        eqSpec @(ZiftResult Int)
        genValiditySpec @(ZiftResult Double)
        functorSpec @ZiftResult
        applicativeSpec @ZiftResult
        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 "<*>" $
                it "succeeds with a linear flushed buffer" $
                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)
        describe "Monad Zift" $
            describe ">>=" $
            it "succeeds with a flushed buffer after the first output" $
            forAll genUnchecked $ \sets ->
                forAll genUnchecked $ \state ->
                    forAll genUnchecked $ \zo1 ->
                        forAll genUnchecked $ \zo2 -> do
                            let zf1 =
                                    Zift $ \_ st ->
                                        pure
                                            ( ZiftSuccess (2 :: Int)
                                            , st
                                              { bufferedOutput =
                                                    zo1 : bufferedOutput st
                                              })
                            let zf2 n =
                                    Zift $ \_ st ->
                                        pure
                                            ( ZiftSuccess (n + 1)
                                            , st
                                              { bufferedOutput =
                                                    zo2 : bufferedOutput st
                                              })
                            let zf = zf1 >>= zf2
                            pchan <- atomically newTChan
                            (zr, zs) <- runZiftTestWith state pchan sets zf
                            zr `shouldBe` ZiftSuccess 3
                            zs `shouldBe` ZiftState {bufferedOutput = [zo2]}
                            buffer <- readAllFrom pchan
                            buffer `shouldBe`
                                (reverse (bufferedOutput state) ++ [zo1])
        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

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
    let zc =
            ZiftContext
            { rootdir = rd
            , 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)