zifter 0.0.1.0 → 0.0.1.1

raw patch · 14 files changed

+596/−162 lines, 14 filesdep +genvalidity-pathdep ~QuickCheckdep ~directoryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: genvalidity-path

Dependency ranges changed: QuickCheck, directory

API changes (from Hackage documentation)

Files

• src/Zifter.hs +85/−39
• src/Zifter/OptParse.hs +8/−0
• src/Zifter/OptParse/Types.hs +2/−0
• src/Zifter/Recurse.hs +70/−16
• src/Zifter/Script.hs +7/−4
• src/Zifter/Script/Types.hs +3/−0
• src/Zifter/Setup.hs +0/−2
• src/Zifter/Setup/Types.hs +3/−3
• src/Zifter/Zift.hs +44/−4
• src/Zifter/Zift/Types.hs +67/−20
• test/Zifter/Zift/Gen.hs +5/−6
• test/Zifter/ZiftSpec.hs +262/−65
• test/ZifterSpec.hs +34/−0
• zifter.cabal +6/−3

@@ -1,21 +1,53 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} +-- | The main 'Zifter' module.+--+-- In most cases this should be the only module you import to start writing a+-- @zift.hs@ script. You will most likely want to import the appropriate+-- modules from the 'zifter-*' companion packages. module Zifter     ( ziftWith     , ziftWithSetup+      -- * Defining your own zift scripts     , preprocessor+    , prechecker     , checker-    , precheck     , ziftP     , recursiveZift-    , module Zifter.Script.Types+      -- ** Zift Script utilities+    , ZiftScript+    , renderZiftSetup+      -- * Defining your own zift actions+    , Zift+    , getRootDir+    , getSettings+    , getSetting+    , Settings(..)+      -- ** Console outputs of a zift action+      --+      -- | Because 'Zift' actions are automatically parallelised, it is important+      -- that they do not arbitrarily output data to the console.+      -- Instead, you should use these functions to output to the console.+      --+      -- The 'ziftWith' and 'ziftWithSetup' functions will take care of ensuring+      -- that the output appears linear.+    , printZift+    , printZiftMessage+    , printPreprocessingDone+    , printPreprocessingError+    , printWithColors+      -- * Utilities+      --+      -- | You will most likely not need these+    , runZiftAuto+    , runZift     ) where -import Control.Concurrent (newEmptyMVar, putMVar, tryTakeMVar) import Control.Concurrent.Async (async, wait) import Control.Concurrent.STM-       (newTChanIO, tryReadTChan, readTChan, writeTChan, atomically)+       (newTChanIO, tryReadTChan, readTChan, writeTChan, atomically,+        orElse, takeTMVar, putTMVar, newEmptyTMVar) import Control.Monad import Path import Path.IO@@ -33,13 +65,24 @@ import Zifter.OptParse import Zifter.Recurse import Zifter.Script-import Zifter.Script.Types import Zifter.Setup import Zifter.Zift +-- | Run a 'ZiftScript' to create the 'ZiftSetup', and then use 'ziftWithSetup'+--+-- > ziftWith = renderZiftSetup >=> ziftWithSetup ziftWith :: ZiftScript () -> IO ()-ziftWith = renderZiftScript >=> (ziftWithSetup . snd)+ziftWith = renderZiftSetup >=> ziftWithSetup +-- | Build a zifter using a 'ZiftSetup'.+--+-- A zifter has the capabilities that you would expect from a 'zift.hs' file:+--+-- * @zift.hs run@:         Run the @zift.hs@ script as a pre-commit hook.+-- * @zift.hs preprocess@:  Run the preprocessor+-- * @zift.hs precheck@:    Run the prechecker+-- * @zift.hs check@:       Run the checker+-- * @zift.hs install@:     Install the @zift.hs@ script as a pre-commit hook. ziftWithSetup :: ZiftSetup -> IO () ziftWithSetup setup = do     hSetBuffering stdout NoBuffering@@ -48,28 +91,32 @@     case d of         DispatchRun -> run setup sets         DispatchPreProcess -> runPreProcessor setup sets+        DispatchPreCheck -> runPreChecker setup sets         DispatchCheck -> runChecker setup sets         DispatchInstall r -> install r sets  run :: ZiftSetup -> Settings -> IO () run ZiftSetup {..} =-    runWith $ \_ -> do+    runZiftAuto $ \_ -> do         runAsPreProcessor ziftPreprocessor-        runAsPreCheck ziftPreCheck+        runAsPreChecker ziftPreChecker         runAsChecker ziftChecker  runPreProcessor :: ZiftSetup -> Settings -> IO () runPreProcessor ZiftSetup {..} =-    runWith $ \_ -> runAsPreProcessor ziftPreprocessor+    runZiftAuto $ \_ -> runAsPreProcessor ziftPreprocessor +runPreChecker :: ZiftSetup -> Settings -> IO ()+runPreChecker ZiftSetup {..} =+    runZiftAuto $ \_ -> runAsPreChecker ziftPreChecker+ runChecker :: ZiftSetup -> Settings -> IO ()-runChecker ZiftSetup {..} = runWith $ \_ -> runAsChecker ziftChecker+runChecker ZiftSetup {..} = runZiftAuto $ \_ -> runAsChecker ziftChecker -runWith :: (ZiftContext -> Zift ()) -> Settings -> IO ()-runWith func sets = do+runZiftAuto :: (ZiftContext -> Zift ()) -> Settings -> IO ()+runZiftAuto func sets = do     rd <- autoRootDir     pchan <- newTChanIO-    fmvar <- newEmptyMVar     let ctx =             ZiftContext             { rootdir = rd@@ -77,17 +124,17 @@             , printChan = pchan             , recursionList = []             }+    runZift ctx (func ctx) >>= exitWith++runZift :: ZiftContext -> Zift () -> IO ExitCode+runZift ctx zfunc = do+    let pchan = printChan ctx+        sets = settings ctx+    fmvar <- atomically newEmptyTMVar     let runner =             withSystemTempDir "zifter" $ \d ->                 withCurrentDir d $ do-                    (r, zs) <--                        let zfunc = do-                                printZiftMessage-                                    ("CHANGED WORKING DIRECTORY TO " ++-                                     toFilePath d)-                                func ctx-                                printZiftMessage "ZIFTER DONE"-                        in zift zfunc ctx mempty+                    (r, zs) <- zift zfunc ctx mempty                     result <-                         case r of                             ZiftFailed err -> do@@ -99,19 +146,16 @@                                 pure $ ExitFailure 1                             ZiftSuccess () -> pure ExitSuccess                     void $ tryFlushZiftBuffer ctx zs-                    putMVar fmvar ()+                    atomically $ putTMVar fmvar ()                     pure result     let outputOne :: ZiftOutput -> IO ()-        outputOne (ZiftOutput commands str)-                -- when False $ do-         = do+        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-                -- print str     let outputAll = do             mout <- atomically $ tryReadTChan pchan             case mout of@@ -120,18 +164,19 @@                     outputOne output                     outputAll     let printer = do-            mdone <- tryTakeMVar fmvar+            mdone <-+                atomically $+                (Left <$> takeTMVar fmvar) `orElse` (Right <$> readTChan pchan)             case mdone of-                Just () -> outputAll-                Nothing -> do-                    output <- atomically $ readTChan pchan+                Left () -> outputAll+                Right output -> do                     outputOne output                     printer     printerAsync <- async printer     runnerAsync <- async runner     result <- wait runnerAsync     wait printerAsync-    exitWith result+    pure result  runAsPreProcessor :: Zift () -> Zift () runAsPreProcessor func = do@@ -139,8 +184,8 @@     func     printZiftMessage "PREPROCESSOR DONE" -runAsPreCheck :: Zift () -> Zift ()-runAsPreCheck func = do+runAsPreChecker :: Zift () -> Zift ()+runAsPreChecker func = do     printZiftMessage "PRECHECKER STARTING"     func     printZiftMessage "PRECHECKER DONE"@@ -168,11 +213,11 @@  install :: Bool -> Settings -> IO () install recursive sets = do+    autoRootDir >>= installIn     if recursive-        then flip runWith sets $ \_ ->+        then flip runZiftAuto sets $ \_ ->                  recursively $ \ziftFile -> liftIO $ installIn $ parent ziftFile         else pure ()-    autoRootDir >>= installIn  installIn :: Path Abs Dir -> IO () installIn rootdir = do@@ -214,19 +259,20 @@     mc <- forgivingAbsence $ readFile $ toFilePath preComitFile     let hookContents = "./zift.hs run\n"     let justDoIt = do-            putStrLn $-                unwords-                    ["Installed pre-commit script in", toFilePath preComitFile]             writeFile (toFilePath preComitFile) hookContents             pcf <- D.getPermissions (toFilePath preComitFile)             D.setPermissions (toFilePath preComitFile) $                 D.setOwnerExecutable True pcf+            putStrLn $+                unwords+                    ["Installed pre-commit script in", toFilePath preComitFile]     case mc of         Nothing -> justDoIt         Just "" -> justDoIt         Just c ->             if c == hookContents-                then putStrLn "Hook already installed."+                then putStrLn $+                     unwords ["Hook already installed for", toFilePath rootdir]                 else die $                      unlines                          [ "Not installing, a pre-commit hook already exists:"

@@ -28,6 +28,7 @@             CommandRun -> DispatchRun             CommandInstall r -> DispatchInstall r             CommandPreProcess -> DispatchPreProcess+            CommandPreCheck -> DispatchPreCheck             CommandCheck -> DispatchCheck  getConfiguration :: Command -> Flags -> IO Configuration@@ -67,6 +68,7 @@     mconcat         [ command "run" parseCommandRun         , command "preprocess" parseCommandPreProcess+        , command "precheck" parseCommandPreCheck         , command "check" parseCommandCheck         , command "install" parseCommandInstall         ]@@ -82,6 +84,12 @@   where     parser = pure CommandPreProcess     modifier = fullDesc <> progDesc "PreProcess according to the zift script."++parseCommandPreCheck :: ParserInfo Command+parseCommandPreCheck = info parser modifier+  where+    parser = pure CommandPreCheck+    modifier = fullDesc <> progDesc "PreCheck according to the zift script."  parseCommandCheck :: ParserInfo Command parseCommandCheck = info parser modifier

@@ -12,6 +12,7 @@     = CommandRun     | CommandInstall Bool -- | Recursive?     | CommandPreProcess+    | CommandPreCheck     | CommandCheck     deriving (Show, Eq) @@ -27,6 +28,7 @@     = DispatchRun     | DispatchInstall Bool -- | recursive ?     | DispatchPreProcess+    | DispatchPreCheck     | DispatchCheck     deriving (Show, Eq, Generic) 

@@ -10,48 +10,102 @@ import Path import Path.IO import System.Exit+import System.IO import System.Process  import Zifter.Script import Zifter.Zift +-- | Recursively call each @zift.hs@ script in the directories below the+-- directory of the currently executing @zift.hs@ script.+--+-- Only the topmost @zift.hs@ script in each directory is executed.+-- This means that, to execute all @zift.hs@ scripts recursively, each of those+-- @zift.hs@ scripts must also have a 'recursiveZift' declaration. recursiveZift :: ZiftScript () recursiveZift = do-    preprocessor $+    preprocessor $ do+        rd <- getRootDir+        printRecursionMsg $+            unwords ["RECURSIVE PREPROCESSING STARTING FROM", toFilePath rd]         recursively $ \ziftFile -> runZiftScript ziftFile "preprocess"-    checker $ recursively $ \ziftFile -> runZiftScript ziftFile "check"+        printRecursionMsg $+            unwords ["RECURSIVE PREPROCESSING FROM", toFilePath rd, "DONE."]+    prechecker $ do+        rd <- getRootDir+        printRecursionMsg $+            unwords ["RECURSIVE PRECHECKING STARTING FROM", toFilePath rd]+        recursively $ \ziftFile -> runZiftScript ziftFile "precheck"+        printRecursionMsg $+            unwords ["RECURSIVE PRECHECKING FROM", toFilePath rd, "DONE."]+    checker $ do+        rd <- getRootDir+        printRecursionMsg $+            unwords ["RECURSIVE CHECKING STARTING FROM", toFilePath rd]+        recursively $ \ziftFile -> runZiftScript ziftFile "check"+        printRecursionMsg $+            unwords ["RECURSIVE CHECKING FROM", toFilePath rd, "DONE"]  recursively :: (Path Abs File -> Zift ()) -> Zift () recursively func = do     fs <- findZiftFilesRecursively-    rd <- getRootDir-    printPreprocessingDone $-        unwords ["RECURSIVE ZIFT STARTING AT", toFilePath rd]     -- Do it in serial (for errors to show up nicely)     -- TODO make it possible to run them in parallel instead?     --      we might have to make it possible for zift to output something machine-readible instead.     forM_ fs func-    printPreprocessingDone $ unwords ["RECURSIVE ZIFT DONE AT", toFilePath rd] +halfIndent :: String -> String+halfIndent = ("  " ++)++indent :: String -> String+indent = halfIndent . ("| " ++)++printRecursionMsg :: String -> Zift ()+printRecursionMsg = printZiftMessage . halfIndent+ runZiftScript :: Path Abs File -> String -> Zift () runZiftScript scriptPath command = do-    printZiftMessage $ unwords ["ZIFTING", toFilePath scriptPath, "RECURSIVELY"]+    rd <- getRootDir+    printRecursionMsg $+        unwords+            [ "ZIFTING"+            , toFilePath scriptPath+            , "AS PART OF RECURSIVE ZIFT FROM"+            , toFilePath rd+            ]     let cmd = unwords [toFilePath scriptPath, command]-    let cp = (shell cmd) {cwd = Just $ toFilePath $ parent scriptPath}-    ec <--        liftIO $ do-            (_, _, _, ph) <- createProcess cp-            waitForProcess ph+    let cp =+            (shell cmd)+            {cwd = Just $ toFilePath $ parent scriptPath, std_out = CreatePipe}+    (_, mouth, merrh, ph) <- liftIO $ createProcess cp+    ec <- liftIO $ waitForProcess ph+    case mouth of+        Nothing -> pure ()+        Just outh -> do+            cts <- liftIO (hGetContents outh)+            forM_ (lines cts) $ printZift . indent+    case merrh of+        Nothing -> pure ()+        Just errh -> liftIO (hGetContents errh) >>= printZift     case ec of-        ExitSuccess -> pure ()+        ExitSuccess ->+            printRecursionMsg $+            unwords+                [ "ZIFTING"+                , toFilePath scriptPath+                , "AS PART OF RECURSIVE ZIFT FROM"+                , toFilePath rd+                , "DONE"+                ]         ExitFailure c -> do-            printPreprocessingError "RECURSIVE ZIFT FAILED"+            printPreprocessingError $ halfIndent "RECURSIVE ZIFT FAILED"             fail $                 unwords-                    [ cmd+                    [ show cmd                     , "failed with exit code"                     , show c-                    , "while recursively zifting."+                    , "while recursively zifting with"+                    , toFilePath scriptPath                     ]  findZiftFilesRecursively :: Zift [Path Abs File]

@@ -1,6 +1,6 @@ module Zifter.Script     ( preprocessor-    , precheck+    , prechecker     , checker     , module Zifter.Script.Types     ) where@@ -9,14 +9,17 @@ import Zifter.Setup import Zifter.Zift +-- | Add a given zift action as a preprocessor. preprocessor :: Zift () -> ZiftScript () preprocessor prep =     ZiftScript {renderZiftScript = pure ((), mempty {ziftPreprocessor = prep})} -precheck :: Zift () -> ZiftScript ()-precheck func =-    ZiftScript {renderZiftScript = pure ((), mempty {ziftPreCheck = func})}+-- | Add a given zift action as a prechecker.+prechecker :: Zift () -> ZiftScript ()+prechecker func =+    ZiftScript {renderZiftScript = pure ((), mempty {ziftPreChecker = func})} +-- | Add a given zift action as a checker. checker :: Zift () -> ZiftScript () checker ch =     ZiftScript {renderZiftScript = pure ((), mempty {ziftChecker = ch})}

@@ -9,6 +9,9 @@     { renderZiftScript :: IO (a, ZiftSetup)     } deriving (Generic) +renderZiftSetup :: ZiftScript a -> IO ZiftSetup+renderZiftSetup = fmap snd . renderZiftScript+ instance Functor ZiftScript where     fmap f (ZiftScript func) =         ZiftScript $ do

@@ -2,6 +2,4 @@     ( module Zifter.Setup.Types     ) where --- import Introduction--- import Zifter.Setup.Types

@@ -8,7 +8,7 @@  data ZiftSetup = ZiftSetup     { ziftPreprocessor :: Zift ()-    , ziftPreCheck :: Zift ()+    , ziftPreChecker :: Zift ()     , ziftChecker :: Zift ()     } deriving (Generic) @@ -16,12 +16,12 @@     mempty =         ZiftSetup         { ziftPreprocessor = pure ()-        , ziftPreCheck = pure ()+        , ziftPreChecker = pure ()         , ziftChecker = pure ()         }     mappend z1 z2 =         ZiftSetup         { ziftPreprocessor = ziftPreprocessor z1 `mappend` ziftPreprocessor z2-        , ziftPreCheck = ziftPreCheck z1 `mappend` ziftPreCheck z2+        , ziftPreChecker = ziftPreChecker z1 `mappend` ziftPreChecker z2         , ziftChecker = ziftChecker z1 `mappend` ziftChecker z2         }

@@ -8,6 +8,7 @@     , printPreprocessingDone     , printPreprocessingError     , printWithColors+    , addZiftOutput     , liftIO     , module Zifter.Zift.Types     ) where@@ -25,34 +26,73 @@ getContext :: Zift ZiftContext getContext = Zift $ \zc st -> pure (ZiftSuccess zc, st) +-- | Get the root directory of the @zift.hs@ script that is being executed. getRootDir :: Zift (Path Abs Dir) getRootDir = fmap rootdir getContext +-- | Get all the 'Settings' getSettings :: Zift Settings getSettings = fmap settings getContext +-- | Get a single setting getSetting :: (Settings -> a) -> Zift a getSetting func = func <$> getSettings +-- | Declare a given list of 'Zift' actions to be execute in parallel. ziftP :: [Zift ()] -> Zift () ziftP = sequenceA_ +-- | Print a message (with a newline appended to the end). printZift :: String -> Zift () printZift = printWithColors [] +-- | Print a message (with a newline appended to the end), in the standard+-- zift script color. This is the function that the zift script uses to output+-- information about the stages of the zift script run. printZiftMessage :: String -> Zift () printZiftMessage = printWithColors [SetColor Foreground Dull Blue] +-- | Print a message (with a newline appended to the end) that signifies that+-- a part of the processing is now done.+--+-- Example:+--+-- > doThingZift :: Zift ()+-- > doThingZift = do+-- >     doThing+-- >     printProcessingDone "doThing completed successfully." printPreprocessingDone :: String -> Zift () printPreprocessingDone = printWithColors [SetColor Foreground Dull Green] +-- | Print a message (with a newline appended to the end) that signifies that+-- a part of the processing failed. This message will not cause the zift script+-- run to fail.+--+-- Example:+--+-- > doDangerousThing :: Zift ()+-- > doDangerousThing = do+-- >     errOrResult <- doThing+-- >     case errOrResult of+-- >         Left err ->+-- >             printPreprocessingError $+-- >                 unwords ["doThing failed with error:", err]+-- >             fail "doThing failed."+-- >         Right result -> do+-- >             printPreprocessingDone+-- >                 unwords ["doThing succeeded with result:", result] printPreprocessingError :: String -> Zift () printPreprocessingError = printWithColors [SetColor Foreground Dull Red] +-- | Print a message (with a newline appended to the end) with custom colors.+--+-- See the [ansi-terminal](https://hackage.haskell.org/package/ansi-terminal)+-- package for more details. printWithColors :: [SGR] -> String -> Zift ()-printWithColors commands str =+printWithColors commands str = addZiftOutput $ ZiftOutput commands str++addZiftOutput :: ZiftOutput -> Zift ()+addZiftOutput zo =     Zift $ \_ st -> do-        let st' =-                ZiftState-                {bufferedOutput = ZiftOutput commands str : bufferedOutput st}+        let st' = ZiftState {bufferedOutput = zo : bufferedOutput st}         pure (ZiftSuccess (), st')

@@ -4,7 +4,7 @@  import Prelude -import Control.Concurrent.Async (concurrently)+import Control.Concurrent.Async (waitEither, wait, cancel, async) import Control.Concurrent.STM (TChan, writeTChan, atomically) import Control.Exception (SomeException, displayException, catch) import Control.Monad.Catch (MonadThrow(..))@@ -18,20 +18,21 @@  import Zifter.OptParse.Types -data ZiftOutput =-    ZiftOutput [SGR]-               String-    deriving (Show, Eq, Generic)+data ZiftOutput = ZiftOutput+    { outputColors :: [SGR]+    , outputMessage :: String+    } deriving (Show, Eq, Generic)  data ZiftContext = ZiftContext     { rootdir :: Path Abs Dir     , settings :: Settings     , printChan :: TChan ZiftOutput-    , recursionList :: [LR] -- In reverse order+    , recursionList :: [LMR] -- In reverse order     } deriving (Generic) -data LR+data LMR     = L+    | M     | R     deriving (Show, Eq, Generic) @@ -52,8 +53,7 @@     { zift :: ZiftContext -> ZiftState -> IO (ZiftResult a, ZiftState)     } deriving (Generic) -instance Monoid a =>-         Monoid (Zift a) where+instance Monoid a => Monoid (Zift a) where     mempty = Zift $ \_ s -> pure (mempty, s)     mappend z1 z2 = mappend <$> z1 <*> z2 @@ -64,22 +64,51 @@             st'' <- tryFlushZiftBuffer rd st'             pure (fmap f r, st'') +-- | 'Zift' actions can be sequenced.+--+-- The implementation automatically parallelises the arguments of the+-- '(<*>)' 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}-            ((fa, zs1), (a, zs2)) <--                concurrently (faf zc1 mempty) (af zc2 mempty)-            let st' = st `mappend` zs1 `mappend` zs2-            st'' <- tryFlushZiftBuffer zc st'-            pure (fa <*> a, st'')+            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 +-- | 'Zift' actions can be composed. instance Monad Zift where     (Zift fa) >>= mb =         Zift $ \rd st -> do-            (ra, st') <- fa rd st+            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 ->@@ -88,9 +117,24 @@                 ZiftFailed e -> pure (ZiftFailed e, st'')     fail = Fail.fail +-- | A 'Zift' action can fail.+--+-- To make a Zift action fail, you can use the 'fail :: String -> Zift a'+-- function.+--+-- 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) +-- | Any IO action can be part of a 'Zift' action.+--+-- This is the most important instance for the end user.+--+-- > liftIO :: IO a -> Zift a+-- allows embedding arbitrary IO actions inside a 'Zift' action.+--+-- The implementation also ensures that exceptions are caught. instance MonadIO Zift where     liftIO act =         Zift $ \_ st ->@@ -107,13 +151,11 @@     | ZiftFailed String     deriving (Show, Eq, Generic) -instance Validity a =>-         Validity (ZiftResult a) where+instance Validity a => Validity (ZiftResult a) where     isValid (ZiftSuccess a) = isValid a     isValid _ = True -instance Monoid a =>-         Monoid (ZiftResult a) where+instance Monoid a => Monoid (ZiftResult a) where     mempty = ZiftSuccess mempty     mappend z1 z2 = mappend <$> z1 <*> z2 @@ -138,10 +180,15 @@ -- | Internal: do not use yourself. tryFlushZiftBuffer :: ZiftContext -> ZiftState -> IO ZiftState tryFlushZiftBuffer ctx st =-    if null $ recursionList ctx+    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)

@@ -40,18 +40,17 @@  instance GenUnchecked SGR +instance GenUnchecked LMR+ instance GenUnchecked ZiftOutput  instance GenUnchecked ZiftState -instance GenUnchecked a =>-         GenUnchecked (ZiftResult a) where+instance GenUnchecked a => GenUnchecked (ZiftResult a) where     genUnchecked = ZiftSuccess <$> genUnchecked -instance GenValid a =>-         GenValid (ZiftResult a) where+instance GenValid a => GenValid (ZiftResult a) where     genValid = ZiftSuccess <$> genValid -instance GenInvalid a =>-         GenInvalid (ZiftResult a) where+instance GenInvalid a => GenInvalid (ZiftResult a) where     genInvalid = ZiftSuccess <$> genInvalid

@@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}  module Zifter.ZiftSpec     ( spec@@ -10,13 +11,18 @@  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@@ -25,6 +31,7 @@         genValiditySpec @(ZiftResult Double)         functorSpec @ZiftResult         applicativeSpec @ZiftResult+        monoidSpec @(ZiftResult String)         monadSpec @ZiftResult     describe "Zift" $ do         describe "Monoid Zift" $ do@@ -81,64 +88,221 @@                         (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+            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) <- runZiftTestWith state pchan sets zf-                                zr `shouldBe` ZiftSuccess 2-                                zs `shouldBe` ZiftState {bufferedOutput = []}+                                (zr, zs) <- runZiftTestWithChan pchan sets zf+                                zr `shouldBe` ZiftSuccess ()                                 buffer <- readAllFrom pchan-                                buffer `shouldBe`-                                    reverse-                                        (bufferedOutput st2 ++-                                         bufferedOutput st1 ++-                                         bufferedOutput state)+                                (buffer ++ reverse (bufferedOutput zs)) `shouldBe`+                                    ls         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 ">>=" $ 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" $@@ -158,28 +322,57 @@                         (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, sets, rl) -> do+        pchan <- atomically newTChan+        let zc =+                ZiftContext+                { rootdir = rd+                , 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 ::+       TChan ZiftOutput -> Settings -> Zift a -> IO (ZiftResult a, ZiftState) runZiftTestWithChan = runZiftTestWith ZiftState {bufferedOutput = []} -runZiftTestWithState :: ZiftState-                     -> Settings-                     -> Zift a-                     -> IO (ZiftResult a, ZiftState)+runZiftTestWithState ::+       ZiftState -> Settings -> Zift a -> IO (ZiftResult a, ZiftState) runZiftTestWithState state sets func = do     pchan <- atomically newTChan     runZiftTestWith state pchan sets func -runZiftTestWith-    :: ZiftState+runZiftTestWith ::+       ZiftState     -> TChan ZiftOutput     -> Settings     -> Zift a@@ -203,3 +396,7 @@         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}

@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}++module ZifterSpec+    ( spec+    ) where++import Test.Hspec+import Test.QuickCheck+import Test.Validity++import Control.Concurrent.STM+import Data.GenValidity.Path ()+import System.Exit (ExitCode(..))++import Zifter+import Zifter.OptParse.Gen ()+import Zifter.Zift+import Zifter.Zift.Gen ()++spec :: Spec+spec =+    describe "ziftWith" $+    it "does nothing with an empty zift action" $+    forAll genUnchecked $ \sets ->+        forAll genValid $ \rd -> do+            pchan <- newTChanIO+            let ctx =+                    ZiftContext+                    { rootdir = rd+                    , settings = sets+                    , printChan = pchan+                    , recursionList = []+                    }+            runZift ctx (pure ()) `shouldReturn` ExitSuccess

@@ -1,5 +1,5 @@ name: zifter-version: 0.0.1.0+version: 0.0.1.1 cabal-version: >=1.10 build-type: Simple license: MIT@@ -51,17 +51,20 @@     build-depends:         base >=4.9 && <=5,         zifter -any,-        QuickCheck >=2.8 && <2.9,+        QuickCheck >=2.9 && <2.10,         genvalidity >=0.3 && <0.4,         genvalidity-hspec >=0.3 && <0.4,+        genvalidity-path >=0.1 && <0.2,         hspec -any,         path -any,         path-io -any,         stm -any,-        ansi-terminal -any+        ansi-terminal -any,+        directory -any     default-language: Haskell2010     hs-source-dirs: test/     other-modules:+        ZifterSpec         Zifter.ZiftSpec         Zifter.Zift.Gen         Zifter.OptParse.Gen