{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} module Zifter.ZiftSpec ( spec ) where import Test.Hspec import Test.QuickCheck import Test.Validity import Data.GenValidity.Path () import Data.Maybe import Data.Monoid import Control.Concurrent.STM import Path.IO import Zifter import Zifter.OptParse import Zifter.Zift import Zifter.Gen () import Zifter.OptParse.Gen () 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 monoidSpec @(ZiftResult String) monadSpec @ZiftResult describe "ziftRunner" $ do it "pure () outputs nothing" $ pure () `outputShouldBe` [ZiftToken [] Nothing] it "pure () twice outputs two tokens" $ let func = do pure () pure () in func `outputShouldBe` [ZiftToken [L] Nothing, ZiftToken [R] Nothing] it "printZift outputs one message" $ printZift "hello" `outputShouldBe` [ ZiftToken [] (Just ZiftOutput {outputColors = [], outputMessage = "hello"}) ] it "printZift twice outputs two messages and two tokens" $ let func = do printZift "hello" printZift "world" in func `outputShouldBe` [ ZiftToken [L] (Just ZiftOutput {outputColors = [], outputMessage = "hello"}) , ZiftToken [R] (Just ZiftOutput {outputColors = [], outputMessage = "world"}) ] describe "addState" $ do it "stores the first output on the left for [L]" $ forAllUnchecked $ \mzo -> addState LinearUnknown (ZiftToken [L] mzo) `shouldBe` Just (LinearBranch (LinearLeaf mzo) LinearUnknown) it "stores the first output on the Right for [R]" $ forAllUnchecked $ \mzo -> addState LinearUnknown (ZiftToken [R] mzo) `shouldBe` Just (LinearBranch LinearUnknown (LinearLeaf mzo)) describe "flushState" $ do let l = LinearLeaf u = LinearUnknown d = LinearDone b = LinearBranch ln = l Nothing t bs es eb = let (as, ab) = flushState bs in do as `shouldBe` es ab `shouldBe` eb it "flushes a simple branch at the top level" $ forAllUnchecked $ \(hello, world) -> t (b (l (Just hello)) (l (Just world))) (b d d) (BufReady [hello, world]) it "flushes and prunes the left side of a branch if the right side is unknown" $ forAllUnchecked $ \msg -> t (b (l (Just msg)) u) (b d u) (BufReady [msg]) it "does not flush the right side of a branch if the left side is unknown" $ forAllUnchecked $ \msg -> let s = b u (l (Just msg)) in t s s BufNotReady it "flushes a branch with two leaves" $ forAllUnchecked $ \(hello, world) -> t (b (l (Just hello)) (l (Just world))) (b d d) (BufReady [hello, world]) it "flushes the entire state when the left side is done and the right side is one level deep" $ forAllUnchecked $ \(hello, world) -> t (b ln (b (l (Just hello)) (l (Just world)))) (b d (b d d)) (BufReady [hello, world]) it "flushes the entire state when the left side is done and the right side is two levels deep" $ forAllUnchecked $ \(hello, big, beautiful, world) -> t (b (l Nothing) (b (b (l (Just hello)) (l (Just big))) (b (l (Just beautiful)) (l (Just world))))) (b d (b (b d d) (b d d))) (BufReady [hello, big, beautiful, world]) it "flushes the entire left half of a complete binary tree of size two if the entire left part is done" $ forAllUnchecked $ \(hello, world) -> t (b (b (l (Just hello)) (l (Just world))) (b u u)) (b (b d d) (b u u)) (BufReady [hello, world]) it "flushes the correct part of the right half of the state when the left part is done and the right side isn't" $ forAllUnchecked $ \(hello, world) -> t (b (l (Just hello)) (b (l (Just world)) u)) (b d (b d u)) (BufReady [hello, world]) it "flushes and the entire left half of a complete binary tree of size two if the entire left part is done" $ forAllUnchecked $ \(hello, beautiful, world) -> t (b (b (l (Just hello)) (l (Just beautiful))) (b (l (Just world)) u)) (b (b d d) (b d u)) (BufReady [hello, beautiful, world]) it "flushes the entire tree for any done tree" $ forAll doneTree $ \st -> let (s', _) = flushState st in s' `shouldBe` makeForceFlushed st it "flushes the entire left tree for any tree whose left part is done" $ forAllShrink doneTree (map makeForceFlushed . shrinkUnchecked) $ \dt -> forAllUnchecked $ \ut -> let s = b dt ut (rs', b2) = flushState ut in t s (b (makeForceFlushed dt) rs') (flushStateAll dt <> b2) it "can only grow the depth of the state" $ forAll (genUnchecked `suchThat` (\(st, token) -> isJust $ processToken st token)) $ \(st, token) -> case processToken st token of Nothing -> pure () -- fine Just (t', _) -> depth t' `shouldSatisfy` (>= depth st) depth :: LinearState -> Int depth LinearUnknown = 1 depth LinearDone = 1 depth (LinearLeaf _) = 1 depth (LinearBranch t1 t2) = max (depth t1) (depth t2) doneTree :: Gen LinearState doneTree = sized $ \s -> oneof [ LinearLeaf <$> genUnchecked , pure LinearDone , do (ls, rs) <- genSplit s LinearBranch <$> resize ls doneTree <*> resize rs doneTree ] makeForceFlushed :: LinearState -> LinearState makeForceFlushed LinearUnknown = LinearUnknown makeForceFlushed LinearDone = LinearDone makeForceFlushed (LinearLeaf _) = LinearDone makeForceFlushed (LinearBranch s1 s2) = LinearBranch (makeForceFlushed s1) (makeForceFlushed s2) outputShouldBe :: Zift () -> [ZiftToken] -> Expectation outputShouldBe func ls = outputShouldSatisfy func (== ls) outputShouldSatisfy :: Zift () -> ([ZiftToken] -> Bool) -> Expectation outputShouldSatisfy func predicate = do rd <- resolveDir' "/tmp/zifter" td <- resolveDir rd ".zifter" pchan <- newTChanIO let ctx = ZiftContext { rootdir = rd , tmpdir = td , settings = Settings {setsOutputColor = False, setsOutputMode = OutputFast} , printChan = pchan , recursionList = [] } fmvar <- newEmptyTMVarIO ec <- ziftRunner ctx fmvar func ec `shouldBe` ZiftSuccess () atomically (takeTMVar fmvar) `shouldReturn` () outs <- readAllFrom pchan outs `shouldSatisfy` predicate 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)