zifter 0.0.1.4 → 0.0.1.5

raw patch · 11 files changed

+536/−513 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Zifter.hs +264/−46
• src/Zifter/OptParse.hs +22/−2
• src/Zifter/OptParse/Types.hs +9/−2
• src/Zifter/Zift.hs +6/−5
• src/Zifter/Zift/Types.hs +43/−92
• test/Zifter/Gen.hs +10/−0
• test/Zifter/OptParse/Gen.hs +2/−0
• test/Zifter/Zift/Gen.hs +3/−3
• test/Zifter/ZiftSpec.hs +174/−360
• test/ZifterSpec.hs +1/−2
• zifter.cabal +2/−1

@@ -1,5 +1,8 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}  -- | The main 'Zifter' module. --@@ -46,13 +49,26 @@       -- | You will most likely not need these     , runZiftAuto     , runZift+    , ziftRunner+    , outputPrinter+    , LinearState(..) -- TODO Split  this into an other module+    , prettyToken+    , prettyState+    , processToken+    , addState+    , flushState+    , Buf(..)+    , pruneState+    , flushStateAll     ) where -import Control.Concurrent.Async (async, wait)+import Control.Concurrent.Async import Control.Concurrent.STM-       (atomically, newEmptyTMVar, newTChanIO, orElse, putTMVar,-        readTChan, takeTMVar, tryReadTChan, writeTChan)+import Control.Exception (SomeException, catch, displayException) import Control.Monad+import Data.Maybe+import Data.Monoid+import GHC.Generics (Generic) import Path import Path.IO import Safe@@ -130,45 +146,116 @@             , printChan = pchan             , recursionList = []             }-    runZift ctx (func ctx) >>= exitWith+    result <- runZift ctx (func ctx)+    code <-+        case result of+            ZiftFailed err -> do+                outputOne (setsOutputColor sets) $+                    ZiftOutput [SetColor Foreground Dull Red] err+                pure $ ExitFailure 1+            ZiftSuccess () -> pure ExitSuccess+    exitWith code -runZift :: ZiftContext -> Zift () -> IO ExitCode+runZift :: ZiftContext -> Zift a -> IO (ZiftResult a) runZift ctx zfunc = do-    let pchan = printChan ctx-        sets = settings ctx     fmvar <- atomically newEmptyTMVar-    let runner =-            withSystemTempDir "zifter" $ \d ->-                withCurrentDir d $ do-                    (r, zs) <- zift zfunc ctx mempty-                    result <--                        case r of-                            ZiftFailed err -> do-                                atomically $-                                    writeTChan pchan $-                                    ZiftOutput-                                        [SetColor Foreground Dull Red]-                                        err-                                pure $ ExitFailure 1-                            ZiftSuccess () -> pure ExitSuccess-                    void $ tryFlushZiftBuffer ctx zs-                    atomically $ putTMVar fmvar ()-                    pure result-    let outputOne :: ZiftOutput -> IO ()-        outputOne (ZiftOutput commands str) = do-            let color = setsOutputColor sets-            when color $ setSGR commands-            putStr str-            when color $ setSGR [Reset]-            putStr "\n" -- Because otherwise it doesn't work?-            hFlush stdout-    let outputAll = do-            mout <- atomically $ tryReadTChan pchan-            case mout of-                Nothing -> pure ()-                Just output -> do-                    outputOne output-                    outputAll+    printerAsync <-+        async $+        outputPrinter (deriveOutputSets $ settings ctx) (printChan ctx) fmvar+    runnerAsync <- async $ ziftRunner ctx fmvar zfunc+    result <- wait runnerAsync+    wait printerAsync+    pure result++ziftRunner :: ZiftContext -> TMVar () -> Zift a -> IO (ZiftResult a)+ziftRunner ctx fmvar zfunc =+    withSystemTempDir "zifter" $ \d ->+        withCurrentDir d $ do+            r <- interpretZift ctx zfunc+            atomically $ putTMVar fmvar ()+            pure r++interpretZift :: forall a. ZiftContext -> Zift a -> IO (ZiftResult a)+interpretZift = go+  where+    sendEmpty :: ZiftContext -> IO ()+    sendEmpty ctx =+        atomically $+        writeTChan (printChan ctx) $ ZiftToken (recursionList ctx) Nothing+    go :: forall b. ZiftContext -> Zift b -> IO (ZiftResult b)+    go ctx (ZiftPure a) = do+        sendEmpty ctx+        pure $ pure a+    go ctx ZiftCtx = do+        sendEmpty ctx+        pure $ pure ctx+    go ctx (ZiftPrint zo) = do+        atomically $+            writeTChan (printChan ctx) $ ZiftToken (recursionList ctx) $ Just zo+        pure $ pure ()+    go ctx (ZiftFail s) = do+        sendEmpty ctx+        pure $ ZiftFailed s+    go ctx (ZiftIO act) = do+        sendEmpty ctx+        (ZiftSuccess <$> act) `catch` handler+      where+        handler :: SomeException -> IO (ZiftResult b)+        handler ex = pure (ZiftFailed $ displayException ex)+    go ctx (ZiftFmap f za) = do+        zr <- go ctx za+        pure $ f <$> zr+    go zc (ZiftApp faf af) = do+        afaf <- async $ go (zc {recursionList = L : recursionList zc}) faf+        aaf <- async $ go (zc {recursionList = R : recursionList zc}) af+        efaa <- waitEither afaf aaf+        let complete fa a = pure $ fa <*> a+        case efaa of+            Left far -> do+                r <-+                    case far of+                        ZiftFailed s -> do+                            cancel aaf+                            pure $ ZiftFailed s+                        _ -> do+                            t2 <- wait aaf+                            complete far t2+                pure r+            Right ar -> do+                r <-+                    case ar of+                        ZiftFailed s -> do+                            cancel afaf+                            pure $ ZiftFailed s+                        _ -> do+                            t1 <- wait afaf+                            complete t1 ar+                pure r+    go rd (ZiftBind fa mb) = do+        ra <- go (rd {recursionList = L : recursionList rd}) fa+        case ra of+            ZiftSuccess a ->+                go (rd {recursionList = R : recursionList rd}) $ mb a+            ZiftFailed e -> pure $ ZiftFailed e++deriveOutputSets :: Settings -> OutputSets+deriveOutputSets Settings {..} =+    OutputSets {outputColor = setsOutputColor, outputMode = setsOutputMode}++data OutputSets = OutputSets+    { outputColor :: Bool+    , outputMode :: OutputMode+    } deriving (Show, Eq)++outputPrinter :: OutputSets -> TChan ZiftToken -> TMVar () -> IO ()+outputPrinter OutputSets {..} =+    (case outputMode of+         OutputLinear -> outputLinear+         OutputFast -> outputFast)+        outputColor++outputFast :: Bool -> TChan ZiftToken -> TMVar () -> IO ()+outputFast color pchan fmvar =     let printer = do             mdone <-                 atomically $@@ -176,13 +263,144 @@             case mdone of                 Left () -> outputAll                 Right output -> do-                    outputOne output+                    outputOneToken output                     printer-    printerAsync <- async printer-    runnerAsync <- async runner-    result <- wait runnerAsync-    wait printerAsync-    pure result+    in printer+  where+    outputOneToken :: ZiftToken -> IO ()+    outputOneToken (ZiftToken _ Nothing) = pure ()+    outputOneToken (ZiftToken _ (Just zo)) = outputOne color zo+    outputAll = do+        mout <- atomically $ tryReadTChan pchan+        case mout of+            Nothing -> pure ()+            Just output -> do+                outputOneToken output+                outputAll++outputLinear :: Bool -> TChan ZiftToken -> TMVar () -> IO ()+outputLinear color pchan fmvar =+    let printer st = do+            mdone <-+                atomically $+                (Left <$> takeTMVar fmvar) `orElse` (Right <$> readTChan pchan)+            case mdone of+                Left () -> outputAll st+                Right token ->+                    case processToken st token of+                        Nothing -> do+                            putStrLn $ prettyToken token+                            putStrLn $ prettyState st+                            error+                                "something went horribly wrong, the above should help"+                        Just (st', buf) -> do+                            outputBuf buf+                            printer st'+    in printer LinearUnknown+  where+    outputBuf :: Buf -> IO ()+    outputBuf BufNotReady = pure ()+    outputBuf (BufReady os) = mapM_ (outputOne color) os+    outputAll st = do+        mout <- atomically $ tryReadTChan pchan+        case mout of+            Nothing -> outputBuf $ flushStateAll st+            Just token ->+                case processToken st token of+                    Nothing -> error "something went horribly wrong"+                    Just (st', buf) -> do+                        outputBuf buf+                        outputAll st'++data LinearState+    = LinearUnknown+    | LinearLeaf (Maybe ZiftOutput)+    | LinearDone+    | LinearBranch LinearState+                   LinearState+    deriving (Show, Eq, Generic)++prettyToken :: ZiftToken -> String+prettyToken (ZiftToken lr _) = concatMap show $ reverse lr++prettyState :: LinearState -> String+prettyState LinearUnknown = "u"+prettyState LinearDone = "d"+prettyState (LinearLeaf Nothing) = "n"+prettyState (LinearLeaf (Just _)) = "m"+prettyState (LinearBranch l1 l2) =+    concat ["(", "b", " ", prettyState l1, " ", prettyState l2, ")"]++processToken :: LinearState -> ZiftToken -> Maybe (LinearState, Buf)+processToken ls zt = do+    ls' <- addState ls zt+    let (ls'', buf) = flushState ls'+        ls''' = pruneState ls''+    pure (ls''', buf)++addState :: LinearState -> ZiftToken -> Maybe LinearState+addState s (ZiftToken ls mzo) = go s $ reverse ls -- FIXME this is probably slow+  where+    u = LinearUnknown+    go :: LinearState -> [LR] -> Maybe LinearState+    go LinearUnknown (L:rest) = LinearBranch <$> go u rest <*> pure u+    go LinearUnknown (R:rest) = LinearBranch u <$> go u rest+    go LinearUnknown [] = Just $ LinearLeaf mzo+    go (LinearBranch l r) (L:rest) = LinearBranch <$> go l rest <*> pure r+    go (LinearBranch l r) (R:rest) = LinearBranch l <$> go r rest+    go LinearDone _ = Nothing+    go (LinearLeaf _) _ = Nothing+        -- error $ unlines ["should never happen (1)", show zt, prettyState s]+    go (LinearBranch _ _) [] = Nothing -- error $ "should never happen (2)" ++ show zt++flushState :: LinearState -> (LinearState, Buf)+flushState = go+  where+    go LinearUnknown = (LinearUnknown, BufNotReady)+    go LinearDone = (LinearDone, BufReady [])+    go (LinearLeaf Nothing) = (LinearDone, BufReady [])+    go (LinearLeaf (Just zo)) = (LinearDone, BufReady [zo])+    go (LinearBranch ls rs) =+        let (ls', lbuf) = go ls+            (rs', rbuf) = go rs+        in case lbuf of+               BufNotReady -> (LinearBranch ls' rs, lbuf)+               BufReady _ -> (LinearBranch ls' rs', lbuf <> rbuf)++data Buf+    = BufNotReady+    | BufReady [ZiftOutput]+    deriving (Show, Eq, Generic)++instance Monoid Buf where+    mempty = BufReady []+    BufNotReady `mappend` _ = BufNotReady+    BufReady zos1 `mappend` BufReady zos2 = BufReady $ zos1 ++ zos2+    BufReady zos1 `mappend` BufNotReady = BufReady zos1++pruneState :: LinearState -> LinearState+pruneState LinearDone = LinearDone+pruneState (LinearLeaf Nothing) = LinearDone+pruneState (LinearLeaf mzo) = LinearLeaf mzo+pruneState LinearUnknown = LinearUnknown+pruneState (LinearBranch ls rs) =+    case (pruneState ls, pruneState rs) of+        (LinearDone, LinearDone) -> LinearDone+        (ls', rs') -> LinearBranch ls' rs'++flushStateAll :: LinearState -> Buf+flushStateAll LinearUnknown = mempty+flushStateAll LinearDone = mempty+flushStateAll (LinearLeaf mzo) = BufReady $ maybeToList mzo+flushStateAll (LinearBranch lsl lsr) = flushStateAll lsl <> flushStateAll lsr++outputOne :: Bool -> ZiftOutput -> IO ()+outputOne color (ZiftOutput commands str) = do+    when color $ setSGR commands+    putStr str+    when color $ setSGR [Reset]+    putStr "\n" -- Because otherwise it doesn't work?+    hFlush stdout  runAsPreProcessor :: Zift () -> Zift () runAsPreProcessor func = do

@@ -5,8 +5,10 @@     , Instructions     , Dispatch(..)     , Settings(..)+    , OutputMode(..)     ) where +import Data.Maybe import Data.Monoid import Options.Applicative import System.Environment (getArgs)@@ -22,7 +24,11 @@ combineToInstructions :: Command -> Flags -> Configuration -> IO Instructions combineToInstructions cmd Flags {..} Configuration = pure (d, sets)   where-    sets = Settings {setsOutputColor = flagsOutputColor}+    sets =+        Settings+        { setsOutputColor = flagsOutputColor+        , setsOutputMode = fromMaybe OutputLinear flagsOutputMode+        }     d =         case cmd of             CommandRun -> DispatchRun@@ -105,7 +111,8 @@     modifier = fullDesc <> progDesc "Install the zift script."  parseFlags :: Parser Flags-parseFlags = Flags <$> doubleSwitch "color" "color in output." mempty+parseFlags =+    Flags <$> doubleSwitch "color" "color in output." mempty <*> outputModeFlag  doubleSwitch :: String -> String -> Mod FlagFields Bool -> Parser Bool doubleSwitch name helpText mods =@@ -129,3 +136,16 @@                        helpText ++ " (default: " ++ show defaultValue ++ ")") <>                   mods))) <|>        pure defaultValue++outputModeFlag :: Parser (Maybe OutputMode)+outputModeFlag =+    (flag'+         (Just OutputLinear)+         (mconcat [long "linear", help "output linearly, reorder as necessary."]) <|>+     flag'+         (Just OutputFast)+         (mconcat+              [ long "fast"+              , help "output as soon as possible, this is likely faster"+              ])) <|>+    pure Nothing

@@ -16,8 +16,9 @@     | CommandCheck     deriving (Show, Eq) -newtype Flags = Flags+data Flags = Flags     { flagsOutputColor :: Bool+    , flagsOutputMode :: Maybe OutputMode     } deriving (Show, Eq)  data Configuration =@@ -32,6 +33,12 @@     | DispatchCheck     deriving (Show, Eq, Generic) -newtype Settings = Settings+data Settings = Settings     { setsOutputColor :: Bool+    , setsOutputMode :: OutputMode     } deriving (Show, Eq, Generic)++data OutputMode+    = OutputLinear+    | OutputFast+    deriving (Show, Eq, Generic)

@@ -29,7 +29,7 @@ import Zifter.Zift.Types  getContext :: Zift ZiftContext-getContext = Zift $ \zc st -> pure (ZiftSuccess zc, st)+getContext = ZiftCtx  -- | Get the root directory of the @zift.hs@ script that is being executed. getRootDir :: Zift (Path Abs Dir)@@ -127,7 +127,8 @@ printWithColors commands str = addZiftOutput $ ZiftOutput commands str  addZiftOutput :: ZiftOutput -> Zift ()-addZiftOutput zo =-    Zift $ \_ st -> do-        let st' = ZiftState {bufferedOutput = zo : bufferedOutput st}-        pure (ZiftSuccess (), st')+addZiftOutput = ZiftPrint+    -- Zift $ \ctx -> do+    --     atomically $+    --         writeTChan (printChan ctx) $ TokenOutput (recursionList ctx) zo+    --     pure $ ZiftSuccess ()

@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}  module Zifter.Zift.Types where  import Prelude -import Control.Concurrent.Async (async, cancel, wait, waitEither)-import Control.Concurrent.STM (TChan, atomically, writeTChan)-import Control.Exception (SomeException, catch, displayException)+import Control.Concurrent.STM import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.Fail as Fail import Control.Monad.IO.Class@@ -19,6 +18,11 @@  import Zifter.OptParse.Types +data ZiftToken =+    ZiftToken [LR]+              (Maybe ZiftOutput)+    deriving (Show, Eq, Generic)+ data ZiftOutput = ZiftOutput     { outputColors :: [SGR]     , outputMessage :: String@@ -28,13 +32,12 @@     { rootdir :: Path Abs Dir     , tmpdir :: Path Abs Dir     , settings :: Settings-    , printChan :: TChan ZiftOutput-    , recursionList :: [LMR] -- In reverse order+    , printChan :: TChan ZiftToken+    , recursionList :: [LR] -- In reverse order     } deriving (Generic) -data LMR+data LR     = L-    | M     | R     deriving (Show, Eq, Generic) @@ -43,30 +46,22 @@ #if MIN_VERSION_validity(0,4,0)     validate zc = rootdir zc <?!> "rootdir" #endif-newtype ZiftState = ZiftState-    { bufferedOutput :: [ZiftOutput] -- In reverse order-    } deriving (Show, Eq, Generic)--instance Monoid ZiftState where-    mempty = ZiftState {bufferedOutput = []}-    mappend zs1 zs2 =-        ZiftState-        {bufferedOutput = bufferedOutput zs2 `mappend` bufferedOutput zs1}--newtype Zift a = Zift-    { zift :: ZiftContext -> ZiftState -> IO (ZiftResult a, ZiftState)-    } deriving (Generic)+data Zift a where+    ZiftPure :: a -> Zift a+    ZiftCtx :: Zift ZiftContext+    ZiftPrint :: ZiftOutput -> Zift ()+    ZiftFail :: String -> Zift a+    ZiftIO :: IO a -> Zift a+    ZiftFmap :: (a -> b) -> Zift a -> Zift b+    ZiftApp :: Zift (a -> b) -> Zift a -> Zift b+    ZiftBind :: Zift a -> (a -> Zift b) -> Zift b  instance Monoid a => Monoid (Zift a) where-    mempty = Zift $ \_ s -> pure (mempty, s)+    mempty = ZiftPure mempty     mappend z1 z2 = mappend <$> z1 <*> z2  instance Functor Zift where-    fmap f (Zift iof) =-        Zift $ \rd st -> do-            (r, st') <- iof rd st-            st'' <- tryFlushZiftBuffer rd st'-            pure (fmap f r, st'')+    fmap = ZiftFmap  -- | 'Zift' actions can be sequenced. --@@ -74,51 +69,12 @@ -- @(<*>)@ function. If any of the actions fails, the other is cancelled -- and the result fails. instance Applicative Zift where-    pure a = Zift $ \_ st -> pure (pure a, st)-    (Zift faf) <*> (Zift af) =-        Zift $ \zc st -> do-            let zc1 = zc {recursionList = L : recursionList zc}-                zc2 = zc {recursionList = R : recursionList zc}-            afaf <- async (faf zc1 mempty)-            aaf <- async (af zc2 mempty)-            efaa <- waitEither afaf aaf-            let complete (fa, zs1) (a, zs2) = do-                    let st' = st `mappend` zs1 `mappend` zs2-                    st'' <- tryFlushZiftBuffer zc st'-                    pure (fa <*> a, st'')-            case efaa of-                Left t1@(far, zs1) ->-                    case far of-                        ZiftFailed s -> do-                            cancel aaf-                            pure (ZiftFailed s, st `mappend` zs1)-                        _ -> do-                            t2 <- wait aaf-                            complete t1 t2-                Right t2@(ar, zs2) ->-                    case ar of-                        ZiftFailed s -> do-                            cancel afaf-                            pure (ZiftFailed s, st `mappend` zs2)-                        _ -> do-                            t1 <- wait afaf-                            complete t1 t2+    pure = ZiftPure+    (<*>) = ZiftApp  -- | 'Zift' actions can be composed. instance Monad Zift where-    (Zift fa) >>= mb =-        Zift $ \rd st -> do-            let newlist =-                    case recursionList rd of-                        (M:_) -> recursionList rd -- don't add another one, it just takes up space.-                        _ -> M : recursionList rd-            (ra, st') <- fa (rd {recursionList = newlist}) st-            st'' <- tryFlushZiftBuffer rd st'-            case ra of-                ZiftSuccess a ->-                    case mb a of-                        Zift pb -> pb rd st''-                ZiftFailed e -> pure (ZiftFailed e, st'')+    (>>=) = ZiftBind     fail = Fail.fail  -- | A 'Zift' action can fail.@@ -129,7 +85,8 @@ -- The implementation uses the given string as the message that is shown at -- the very end of the run. instance MonadFail Zift where-    fail s = Zift $ \_ st -> pure (ZiftFailed s, st)+    fail = ZiftFail+    -- fail s = Zift $ \_ -> pure $ ZiftFailed s  -- | Any IO action can be part of a 'Zift' action. --@@ -140,15 +97,10 @@ -- -- The implementation also ensures that exceptions are caught. instance MonadIO Zift where-    liftIO act =-        Zift $ \_ st ->-            (act >>= (\r -> pure (ZiftSuccess r, st))) `catch` handler st-      where-        handler :: ZiftState -> SomeException -> IO (ZiftResult a, ZiftState)-        handler s ex = pure (ZiftFailed $ displayException ex, s)+    liftIO = ZiftIO  instance MonadThrow Zift where-    throwM e = Zift $ \_ _ -> throwM e+    throwM = ZiftIO . throwM  data ZiftResult a     = ZiftSuccess a@@ -180,19 +132,18 @@  instance MonadFail ZiftResult where     fail = ZiftFailed---- | Internal: do not use yourself.-tryFlushZiftBuffer :: ZiftContext -> ZiftState -> IO ZiftState-tryFlushZiftBuffer ctx st =-    if flushable $ recursionList ctx-        then do-            let zos = reverse $ bufferedOutput st-                st' = st {bufferedOutput = []}-            atomically $ mapM_ (writeTChan $ printChan ctx) zos-            pure st'-        else pure st---- The buffer is flushable when it's guaranteed to be the first in the in-order--- of the evaluation tree.-flushable :: [LMR] -> Bool-flushable = all (== M) . dropWhile (== L)+-- -- | Internal: do not use yourself.+-- tryFlushZiftBuffer :: ZiftContext -> ZiftState -> IO ZiftState+-- tryFlushZiftBuffer ctx st =+--     if flushable $ recursionList ctx+--         then do+--             let zos = reverse $ bufferedOutput st+--                 st' = st {bufferedOutput = []}+--             atomically $ mapM_ (writeTChan $ printChan ctx) zos+--             pure st'+--         else pure st+--+-- -- The buffer is flushable when it's guaranteed to be the first in the in-order+-- -- of the evaluation tree.+-- flushable :: [LR] -> Bool+-- flushable = all (== L)

@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Zifter.Gen where++import Data.GenValidity++import Zifter+import Zifter.Zift.Gen ()++instance GenUnchecked LinearState

@@ -6,4 +6,6 @@  import Test.Validity +instance GenUnchecked OutputMode+ instance GenUnchecked Settings

@@ -43,11 +43,11 @@  instance GenUnchecked SGR -instance GenUnchecked LMR+instance GenUnchecked LR -instance GenUnchecked ZiftOutput+instance GenUnchecked ZiftToken -instance GenUnchecked ZiftState+instance GenUnchecked ZiftOutput  instance (Validity a) => Validity (RGB a) where     validate RGB {..} =

@@ -9,19 +9,21 @@ import Test.QuickCheck import Test.Validity -import Path.IO+import Data.GenValidity.Path ()+import Data.Maybe+import Data.Monoid -import Control.Concurrent (threadDelay) import Control.Concurrent.STM-import Data.Foldable-import Data.GenValidity.Path () -import Zifter.OptParse.Gen ()-import Zifter.OptParse.Types+import Path.IO++import Zifter+import Zifter.OptParse import Zifter.Zift-import Zifter.Zift.Gen () -{-# ANN module "HLint: ignore Reduce duplication" #-}+import Zifter.Gen ()+import Zifter.OptParse.Gen ()+import Zifter.Zift.Gen ()  spec :: Spec spec = do@@ -33,366 +35,182 @@         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 ()+    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) -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+depth :: LinearState -> Int+depth LinearUnknown = 1+depth LinearDone = 1+depth (LinearLeaf _) = 1+depth (LinearBranch t1 t2) = max (depth t1) (depth t2) -runZiftTest :: Settings -> Zift a -> IO (ZiftResult a, ZiftState)-runZiftTest sets func = do-    pchan <- atomically newTChan-    runZiftTestWithChan pchan sets func+doneTree :: Gen LinearState+doneTree =+    sized $ \s ->+        oneof+            [ LinearLeaf <$> genUnchecked+            , pure LinearDone+            , do (ls, rs) <- genSplit s+                 LinearBranch <$> resize ls doneTree <*> resize rs doneTree+            ] -runZiftTestWithChan ::-       TChan ZiftOutput -> Settings -> Zift a -> IO (ZiftResult a, ZiftState)-runZiftTestWithChan = runZiftTestWith ZiftState {bufferedOutput = []}+makeForceFlushed :: LinearState -> LinearState+makeForceFlushed LinearUnknown = LinearUnknown+makeForceFlushed LinearDone = LinearDone+makeForceFlushed (LinearLeaf _) = LinearDone+makeForceFlushed (LinearBranch s1 s2) =+    LinearBranch (makeForceFlushed s1) (makeForceFlushed s2) -runZiftTestWithState ::-       ZiftState -> Settings -> Zift a -> IO (ZiftResult a, ZiftState)-runZiftTestWithState state sets func = do-    pchan <- atomically newTChan-    runZiftTestWith state pchan sets func+outputShouldBe :: Zift () -> [ZiftToken] -> Expectation+outputShouldBe func ls = outputShouldSatisfy func (== ls) -runZiftTestWith ::-       ZiftState-    -> TChan ZiftOutput-    -> Settings-    -> Zift a-    -> IO (ZiftResult a, ZiftState)-runZiftTestWith zs pchan sets func = do-    rd <- getCurrentDir+outputShouldSatisfy :: Zift () -> ([ZiftToken] -> Bool) -> Expectation+outputShouldSatisfy func predicate = do+    rd <- resolveDir' "/tmp/zifter"     td <- resolveDir rd ".zifter"-    let zc =+    pchan <- newTChanIO+    let ctx =             ZiftContext             { rootdir = rd             , tmpdir = td-            , settings = sets+            , settings =+                  Settings+                  {setsOutputColor = False, setsOutputMode = OutputFast}             , printChan = pchan             , recursionList = []             }-    zift func zc zs+    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@@ -402,7 +220,3 @@         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}

@@ -12,7 +12,6 @@  import Control.Concurrent.STM import Data.GenValidity.Path ()-import System.Exit (ExitCode(..))  import Zifter import Zifter.OptParse.Gen ()@@ -35,4 +34,4 @@                     , printChan = pchan                     , recursionList = []                     }-            runZift ctx (pure ()) `shouldReturn` ExitSuccess+            runZift ctx (pure ()) `shouldReturn` ZiftSuccess ()

@@ -1,5 +1,5 @@ name: zifter-version: 0.0.1.4+version: 0.0.1.5 cabal-version: >=1.10 build-type: Simple license: MIT@@ -66,6 +66,7 @@     hs-source-dirs: test/     other-modules:         ZifterSpec+        Zifter.Gen         Zifter.ZiftSpec         Zifter.Zift.Gen         Zifter.OptParse.Gen