packages feed

zifter (empty) → 0.0.0.0

raw patch · 18 files changed

+1131/−0 lines, 18 filesdep +QuickCheckdep +ansi-terminaldep +asyncsetup-changed

Dependencies added: QuickCheck, ansi-terminal, async, base, directory, exceptions, filepath, genvalidity, genvalidity-hspec, hspec, optparse-applicative, path, path-io, process, safe, stm, validity, validity-path, zifter

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ src/Zifter.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}++module Zifter+    ( ziftWith+    , ziftWithSetup+    , preprocessor+    , checker+    , precheck+    , ziftP+    , recursiveZift+    , module Zifter.Script.Types+    ) where++import Control.Concurrent (newEmptyMVar, putMVar, tryTakeMVar)+import Control.Concurrent.Async (async, wait)+import Control.Concurrent.STM+       (newTChanIO, tryReadTChan, readTChan, writeTChan, atomically)+import Control.Monad+import Path+import Path.IO+import Safe+import System.Console.ANSI+import qualified System.Directory as D+       (canonicalizePath, setPermissions, getPermissions,+        setOwnerExecutable)+import System.Environment (getProgName)+import System.Exit (die)+import qualified System.FilePath as FP (splitPath, joinPath)+import System.IO+       (hSetBuffering, BufferMode(NoBuffering), stderr, stdout, hFlush)++import Zifter.OptParse+import Zifter.Recurse+import Zifter.Script+import Zifter.Script.Types+import Zifter.Setup+import Zifter.Zift++ziftWith :: ZiftScript () -> IO ()+ziftWith = renderZiftScript >=> (ziftWithSetup . snd)++ziftWithSetup :: ZiftSetup -> IO ()+ziftWithSetup setup = do+    hSetBuffering stdout NoBuffering+    hSetBuffering stderr NoBuffering+    (d, sets) <- getInstructions+    case d of+        DispatchRun -> run setup sets+        DispatchPreProcess -> runPreProcessor setup sets+        DispatchCheck -> runChecker setup sets+        DispatchInstall r -> install r sets++run :: ZiftSetup -> Settings -> IO ()+run ZiftSetup {..} =+    runWith $ \_ -> do+        runAsPreProcessor ziftPreprocessor+        runAsPreCheck ziftPreCheck+        runAsChecker ziftChecker++runPreProcessor :: ZiftSetup -> Settings -> IO ()+runPreProcessor ZiftSetup {..} =+    runWith $ \_ -> runAsPreProcessor ziftPreprocessor++runChecker :: ZiftSetup -> Settings -> IO ()+runChecker ZiftSetup {..} = runWith $ \_ -> runAsChecker ziftChecker++runWith :: (ZiftContext -> Zift ()) -> Settings -> IO ()+runWith func sets = do+    rd <- autoRootDir+    pchan <- newTChanIO+    fmvar <- newEmptyMVar+    let ctx =+            ZiftContext+            { rootdir = rd+            , settings = sets+            , printChan = pchan+            , recursionList = []+            }+    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+                    case r of+                        ZiftFailed err ->+                            atomically $+                            writeTChan pchan $+                            ZiftOutput [SetColor Foreground Dull Red] err+                        ZiftSuccess () -> pure ()+                    void $ tryFlushZiftBuffer ctx zs+                    putMVar fmvar ()+    let outputOne :: ZiftOutput -> IO ()+        outputOne (ZiftOutput commands str)+                -- when False $ do+         = 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+                Nothing -> pure ()+                Just output -> do+                    outputOne output+                    outputAll+    let printer = do+            mdone <- tryTakeMVar fmvar+            case mdone of+                Just () -> outputAll+                Nothing -> do+                    output <- atomically $ readTChan pchan+                    outputOne output+                    printer+    printerAsync <- async printer+    runnerAsync <- async runner+    wait runnerAsync+    wait printerAsync++runAsPreProcessor :: Zift () -> Zift ()+runAsPreProcessor func = do+    printZiftMessage "PREPROCESSOR STARTING"+    func+    printZiftMessage "PREPROCESSOR DONE"++runAsPreCheck :: Zift () -> Zift ()+runAsPreCheck func = do+    printZiftMessage "PRECHECKER STARTING"+    func+    printZiftMessage "PRECHECKER DONE"++runAsChecker :: Zift () -> Zift ()+runAsChecker func = do+    printZiftMessage "CHECKER STARTING"+    func+    printZiftMessage "CHECKER DONE"++autoRootDir :: IO (Path Abs Dir)+autoRootDir = do+    pn <- getProgName+    here <- getCurrentDir+    (_, fs) <- listDir here+    unless (pn `elem` map (toFilePath . filename) fs) $+        die $+        unwords+            [ pn+            , "not found at"+            , toFilePath here+            , "the zift script must be run in the right directory."+            ]+    pure here++install :: Bool -> Settings -> IO ()+install recursive sets = do+    if recursive+        then flip runWith sets $ \_ ->+                 recursively $ \ziftFile -> liftIO $ installIn $ parent ziftFile+        else pure ()+    autoRootDir >>= installIn++installIn :: Path Abs Dir -> IO ()+installIn rootdir = do+    let gitdir = rootdir </> dotGitDir+    gd <- doesDirExist gitdir+    let gitfile = rootdir </> dotGitFile+    gf <- doesFileExist gitfile+    ghd <-+        case (gd, gf) of+            (True, True) -> die "The .git dir is both a file and a directory?"+            (False, False) ->+                die+                    "The .git dir is nor a file nor a directory, I don't know what to do."+            (True, False) -> pure $ gitdir </> hooksDir+            (False, True) -> do+                contents <- readFile $ toFilePath gitfile+                case splitAt (length "gitdir: ") contents of+                    ("gitdir: ", rest) ->+                        case initMay rest of+                            Just gitdirref -> do+                                sp <-+                                    D.canonicalizePath $+                                    toFilePath rootdir ++ gitdirref+                                let figureOutDoubleDots =+                                        FP.joinPath . go [] . FP.splitPath+                                      where+                                        go acc [] = reverse acc+                                        go (_:acc) ("../":xs) = go acc xs+                                        go acc (x:xs) = go (x : acc) xs+                                realgitdir <-+                                    parseAbsDir $ figureOutDoubleDots sp+                                pure $ realgitdir </> hooksDir+                            Nothing ->+                                die "no gitdir reference found in .git file."+                    _ ->+                        die+                            "Found weird contents of the .git file. It is a file but does not start with 'gitdir: '. I don't know what to do."+    let preComitFile = ghd </> $(mkRelFile "pre-commit")+    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+    case mc of+        Nothing -> justDoIt+        Just "" -> justDoIt+        Just c ->+            if c == hookContents+                then putStrLn "Hook already installed."+                else die $+                     unlines+                         [ "Not installing, a pre-commit hook already exists:"+                         , show c+                         ]++dotGitDir :: Path Rel Dir+dotGitDir = $(mkRelDir ".git")++dotGitFile :: Path Rel File+dotGitFile = $(mkRelFile ".git")++hooksDir :: Path Rel Dir+hooksDir = $(mkRelDir "hooks")
+ src/Zifter/OptParse.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE RecordWildCards #-}++module Zifter.OptParse+    ( module Zifter.OptParse+    , Instructions+    , Dispatch(..)+    , Settings(..)+    ) where++import Data.Monoid+import Options.Applicative+import System.Environment (getArgs)++import Zifter.OptParse.Types++getInstructions :: IO Instructions+getInstructions = do+    (cmd, flags) <- getArguments+    config <- getConfiguration cmd flags+    combineToInstructions cmd flags config++combineToInstructions :: Command -> Flags -> Configuration -> IO Instructions+combineToInstructions cmd Flags {..} Configuration = pure (d, sets)+  where+    sets = Settings {setsOutputColor = flagsOutputColor}+    d =+        case cmd of+            CommandRun -> DispatchRun+            CommandInstall r -> DispatchInstall r+            CommandPreProcess -> DispatchPreProcess+            CommandCheck -> DispatchCheck++getConfiguration :: Command -> Flags -> IO Configuration+getConfiguration _ _ = pure Configuration++getArguments :: IO Arguments+getArguments = do+    args <- getArgs+    let result = runArgumentsParser args+    handleParseResult result++runArgumentsParser :: [String] -> ParserResult Arguments+runArgumentsParser = execParserPure pfs argParser+  where+    pfs =+        ParserPrefs+        { prefMultiSuffix = ""+        , prefDisambiguate = True+        , prefShowHelpOnError = True+        , prefShowHelpOnEmpty = True+        , prefBacktrack = True+        , prefColumns = 80+        }++argParser :: ParserInfo Arguments+argParser = info (helper <*> parseArgs) hlp+  where+    hlp = fullDesc <> progDesc description+    description = "Zifter"++parseArgs :: Parser Arguments+parseArgs = (,) <$> parseCommand <*> parseFlags++parseCommand :: Parser Command+parseCommand =+    hsubparser $+    mconcat+        [ command "run" parseCommandRun+        , command "preprocess" parseCommandPreProcess+        , command "check" parseCommandCheck+        , command "install" parseCommandInstall+        ]++parseCommandRun :: ParserInfo Command+parseCommandRun = info parser modifier+  where+    parser = pure CommandRun+    modifier = fullDesc <> progDesc "Run the zift script."++parseCommandPreProcess :: ParserInfo Command+parseCommandPreProcess = info parser modifier+  where+    parser = pure CommandPreProcess+    modifier = fullDesc <> progDesc "PreProcess according to the zift script."++parseCommandCheck :: ParserInfo Command+parseCommandCheck = info parser modifier+  where+    parser = pure CommandCheck+    modifier = fullDesc <> progDesc "Check according to the zift script."++parseCommandInstall :: ParserInfo Command+parseCommandInstall = info parser modifier+  where+    parser =+        CommandInstall <$> doubleSwitch "recursive" "Install recursively" mempty+    modifier = fullDesc <> progDesc "Install the zift script."++parseFlags :: Parser Flags+parseFlags = Flags <$> doubleSwitch "color" "color in output." mempty++doubleSwitch :: String -> String -> Mod FlagFields Bool -> Parser Bool+doubleSwitch name helpText mods =+    let enabledValue = True+        disabledValue = False+        defaultValue = True+    in (last <$>+        some+            ((flag'+                  enabledValue+                  (hidden <> internal <> long name <> help helpText <> mods) <|>+              flag'+                  disabledValue+                  (hidden <> internal <> long ("no-" ++ name) <> help helpText <>+                   mods)) <|>+             flag'+                 disabledValue+                 (long ("[no-]" ++ name) <>+                  help+                      ("Enable/disable " +++                       helpText ++ " (default: " ++ show defaultValue ++ ")") <>+                  mods))) <|>+       pure defaultValue
+ src/Zifter/OptParse/Types.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveGeneric #-}++module Zifter.OptParse.Types where++import GHC.Generics++type Arguments = (Command, Flags)++type Instructions = (Dispatch, Settings)++data Command+    = CommandRun+    | CommandInstall Bool -- | Recursive?+    | CommandPreProcess+    | CommandCheck+    deriving (Show, Eq)++newtype Flags = Flags+    { flagsOutputColor :: Bool+    } deriving (Show, Eq)++data Configuration =+    Configuration+    deriving (Show, Eq)++data Dispatch+    = DispatchRun+    | DispatchInstall Bool -- | recursive ?+    | DispatchPreProcess+    | DispatchCheck+    deriving (Show, Eq, Generic)++newtype Settings = Settings+    { setsOutputColor :: Bool+    } deriving (Show, Eq, Generic)
+ src/Zifter/Recurse.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TemplateHaskell #-}++module Zifter.Recurse+    ( recursiveZift+    , recursively+    ) where++import Control.Monad+import Control.Monad.IO.Class+import Path+import Path.IO+import System.Exit+import System.Process++import Zifter.Script+import Zifter.Zift++recursiveZift :: ZiftScript ()+recursiveZift = do+    preprocessor $+        recursively $ \ziftFile -> runZiftScript ziftFile "preprocess"+    checker $ recursively $ \ziftFile -> runZiftScript ziftFile "check"++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]++runZiftScript :: Path Abs File -> String -> Zift ()+runZiftScript scriptPath command = do+    printZiftMessage $ unwords ["ZIFTING", toFilePath scriptPath, "RECURSIVELY"]+    let cmd = unwords [toFilePath scriptPath, command]+    let cp = (shell cmd) {cwd = Just $ toFilePath $ parent scriptPath}+    ec <-+        liftIO $ do+            (_, _, _, ph) <- createProcess cp+            waitForProcess ph+    case ec of+        ExitSuccess -> pure ()+        ExitFailure c -> do+            printPreprocessingError "RECURSIVE ZIFT FAILED"+            fail $+                unwords+                    [ cmd+                    , "failed with exit code"+                    , show c+                    , "while recursively zifting."+                    ]++findZiftFilesRecursively :: Zift [Path Abs File]+findZiftFilesRecursively = do+    rd <- getRootDir+    let filterZiftFiles = filter ((== $(mkRelFile "zift.hs")) . filename) -- TODO generalise to given predicate+    let recurser absdir dirs files =+            if absdir == rd+                then pure $ WalkExclude []+                else do+                    let ziftFiles = filterZiftFiles files+                    case ziftFiles of+                        [] -> pure $ WalkExclude [] -- No zift files found, recurse further downward.+                        -- Zift files found, run each of them but don't recurse further. That's their job.+                        _ -> pure $ WalkExclude dirs+    let outputWriter absdir _ files =+            pure $+            if absdir == rd+                then []+                else filterZiftFiles files+    walkDirAccum (Just recurser) outputWriter rd
+ src/Zifter/Script.hs view
@@ -0,0 +1,22 @@+module Zifter.Script+    ( preprocessor+    , precheck+    , checker+    , module Zifter.Script.Types+    ) where++import Zifter.Script.Types+import Zifter.Setup+import Zifter.Zift++preprocessor :: Zift () -> ZiftScript ()+preprocessor prep =+    ZiftScript {renderZiftScript = pure ((), mempty {ziftPreprocessor = prep})}++precheck :: Zift () -> ZiftScript ()+precheck func =+    ZiftScript {renderZiftScript = pure ((), mempty {ziftPreCheck = func})}++checker :: Zift () -> ZiftScript ()+checker ch =+    ZiftScript {renderZiftScript = pure ((), mempty {ziftChecker = ch})}
+ src/Zifter/Script/Types.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveGeneric #-}++module Zifter.Script.Types where++import GHC.Generics+import Zifter.Setup.Types++newtype ZiftScript a = ZiftScript+    { renderZiftScript :: IO (a, ZiftSetup)+    } deriving (Generic)++instance Functor ZiftScript where+    fmap f (ZiftScript func) =+        ZiftScript $ do+            (a, zs) <- func+            pure (f a, zs)++instance Applicative ZiftScript where+    pure a = ZiftScript $ pure (a, mempty)+    (ZiftScript funcf) <*> (ZiftScript funca) =+        ZiftScript $ do+            (f, z1) <- funcf+            (a, z2) <- funca+            pure (f a, z1 `mappend` z2)++instance Monad ZiftScript where+    (ZiftScript afunc) >>= func =+        ZiftScript $ do+            (a, z1) <- afunc+            let (ZiftScript bfunc) = func a+            (b, z2) <- bfunc+            pure (b, z1 `mappend` z2)
+ src/Zifter/Setup.hs view
@@ -0,0 +1,7 @@+module Zifter.Setup+    ( module Zifter.Setup.Types+    ) where++-- import Introduction+--+import Zifter.Setup.Types
+ src/Zifter/Setup/Types.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}++module Zifter.Setup.Types where++import GHC.Generics++import Zifter.Zift.Types++data ZiftSetup = ZiftSetup+    { ziftPreprocessor :: Zift ()+    , ziftPreCheck :: Zift ()+    , ziftChecker :: Zift ()+    } deriving (Generic)++instance Monoid ZiftSetup where+    mempty =+        ZiftSetup+        { ziftPreprocessor = pure ()+        , ziftPreCheck = pure ()+        , ziftChecker = pure ()+        }+    mappend z1 z2 =+        ZiftSetup+        { ziftPreprocessor = ziftPreprocessor z1 `mappend` ziftPreprocessor z2+        , ziftPreCheck = ziftPreCheck z1 `mappend` ziftPreCheck z2+        , ziftChecker = ziftChecker z1 `mappend` ziftChecker z2+        }
+ src/Zifter/Types.hs view
@@ -0,0 +1,1 @@+module Zifter.Types where
+ src/Zifter/Zift.hs view
@@ -0,0 +1,58 @@+module Zifter.Zift+    ( getRootDir+    , getSettings+    , getSetting+    , ziftP+    , printZift+    , printZiftMessage+    , printPreprocessingDone+    , printPreprocessingError+    , printWithColors+    , liftIO+    , module Zifter.Zift.Types+    ) where++import Control.Monad.IO.Class (liftIO)+import Data.Foldable++import System.Console.ANSI++import Path++import Zifter.OptParse.Types+import Zifter.Zift.Types++getContext :: Zift ZiftContext+getContext = Zift $ \zc st -> pure (ZiftSuccess zc, st)++getRootDir :: Zift (Path Abs Dir)+getRootDir = fmap rootdir getContext++getSettings :: Zift Settings+getSettings = fmap settings getContext++getSetting :: (Settings -> a) -> Zift a+getSetting func = func <$> getSettings++ziftP :: [Zift ()] -> Zift ()+ziftP = sequenceA_++printZift :: String -> Zift ()+printZift = printWithColors []++printZiftMessage :: String -> Zift ()+printZiftMessage = printWithColors [SetColor Foreground Dull Blue]++printPreprocessingDone :: String -> Zift ()+printPreprocessingDone = printWithColors [SetColor Foreground Dull Green]++printPreprocessingError :: String -> Zift ()+printPreprocessingError = printWithColors [SetColor Foreground Dull Red]++printWithColors :: [SGR] -> String -> Zift ()+printWithColors commands str =+    Zift $ \_ st -> do+        let st' =+                ZiftState+                {bufferedOutput = ZiftOutput commands str : bufferedOutput st}+        pure (ZiftSuccess (), st')
+ src/Zifter/Zift/Types.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveGeneric #-}++module Zifter.Zift.Types where++import Prelude++import Control.Concurrent.Async (concurrently)+import Control.Concurrent.STM (TChan, writeTChan, atomically)+import Control.Exception (SomeException, displayException, catch)+import Control.Monad.Catch (MonadThrow(..))+import Control.Monad.Fail as Fail+import Control.Monad.IO.Class+import Data.Validity+import Data.Validity.Path ()+import GHC.Generics+import Path+import System.Console.ANSI (SGR)++import Zifter.OptParse.Types++data ZiftOutput =+    ZiftOutput [SGR]+               String+    deriving (Show, Eq, Generic)++data ZiftContext = ZiftContext+    { rootdir :: Path Abs Dir+    , settings :: Settings+    , printChan :: TChan ZiftOutput+    , recursionList :: [LR] -- In reverse order+    } deriving (Generic)++data LR+    = L+    | R+    deriving (Show, Eq, Generic)++instance Validity ZiftContext where+    isValid = isValid . rootdir++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)++instance Monoid a =>+         Monoid (Zift a) where+    mempty = Zift $ \_ s -> pure (mempty, s)+    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'')++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}+            -- faa <- async $ faf zc1 st+            -- aa <- async $ af zc2 st+            -- (fa, zs1) <- wait faa+            -- (a, zs2) <- wait aa+            ((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'')++instance Monad Zift where+    (Zift fa) >>= mb =+        Zift $ \rd st -> do+            (ra, st') <- fa rd 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'')+    fail = Fail.fail++instance MonadFail Zift where+    fail s = Zift $ \_ st -> pure (ZiftFailed s, st)++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)++instance MonadThrow Zift where+    throwM e = Zift $ \_ _ -> throwM e++data ZiftResult a+    = ZiftSuccess a+    | ZiftFailed String+    deriving (Show, Eq, Generic)++instance Validity a =>+         Validity (ZiftResult a) where+    isValid (ZiftSuccess a) = isValid a+    isValid _ = True++instance Monoid a =>+         Monoid (ZiftResult a) where+    mempty = ZiftSuccess mempty+    mappend z1 z2 = mappend <$> z1 <*> z2++instance Functor ZiftResult where+    fmap f (ZiftSuccess a) = ZiftSuccess $ f a+    fmap _ (ZiftFailed s) = ZiftFailed s++instance Applicative ZiftResult where+    pure = ZiftSuccess+    (ZiftSuccess f) <*> (ZiftSuccess a) = ZiftSuccess $ f a+    (ZiftFailed e) <*> (ZiftSuccess _) = ZiftFailed e+    (ZiftSuccess _) <*> (ZiftFailed e) = ZiftFailed e+    (ZiftFailed e1) <*> (ZiftFailed e2) = ZiftFailed $ unwords [e1, e2]++instance Monad ZiftResult where+    (ZiftSuccess a) >>= fb = fb a+    (ZiftFailed e) >>= _ = ZiftFailed e++instance MonadFail ZiftResult where+    fail = ZiftFailed++-- | Internal: do not use yourself.+tryFlushZiftBuffer :: ZiftContext -> ZiftState -> IO ZiftState+tryFlushZiftBuffer ctx st =+    if null $ recursionList ctx+        then do+            let zos = reverse $ bufferedOutput st+                st' = st {bufferedOutput = []}+            atomically $ mapM_ (writeTChan $ printChan ctx) zos+            pure st'+        else pure st
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Zifter/OptParse/Gen.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Zifter.OptParse.Gen where++import Zifter.OptParse.Types++import Test.Validity++instance GenUnchecked Settings
+ test/Zifter/Zift/Gen.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-}++module Zifter.Zift.Gen where++import GHC.Generics++import Data.GenValidity++import System.Console.ANSI++import Zifter.Zift.Types++deriving instance Generic Underlining++instance GenUnchecked Underlining++deriving instance Generic BlinkSpeed++instance GenUnchecked BlinkSpeed++deriving instance Generic ConsoleLayer++instance GenUnchecked ConsoleLayer++deriving instance Generic Color++instance GenUnchecked Color++deriving instance Generic ConsoleIntensity++instance GenUnchecked ConsoleIntensity++deriving instance Generic ColorIntensity++instance GenUnchecked ColorIntensity++deriving instance Generic SGR++instance GenUnchecked SGR++instance GenUnchecked ZiftOutput++instance GenUnchecked ZiftState++instance GenUnchecked a =>+         GenUnchecked (ZiftResult a) where+    genUnchecked = ZiftSuccess <$> genUnchecked++instance GenValid a =>+         GenValid (ZiftResult a) where+    genValid = ZiftSuccess <$> genValid++instance GenInvalid a =>+         GenInvalid (ZiftResult a) where+    genInvalid = ZiftSuccess <$> genInvalid
+ test/Zifter/ZiftSpec.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE TypeApplications #-}++module Zifter.ZiftSpec+    ( spec+    ) where++import Test.Hspec+import Test.QuickCheck+import Test.Validity++import Path.IO++import Control.Concurrent.STM++import Zifter.OptParse.Gen ()+import Zifter.OptParse.Types+import Zifter.Zift+import Zifter.Zift.Gen ()++spec :: Spec+spec = do+    describe "ZiftOutput" $ eqSpec @ZiftOutput+    describe "ZiftResult" $ do+        eqSpec @(ZiftResult Int)+        genValiditySpec @(ZiftResult Double)+        functorSpec @ZiftResult+        applicativeSpec @ZiftResult+        monadSpec @ZiftResult+    describe "Zift" $ do+        describe "Monoid Zift" $ do+            describe "mempty" $+                it "succeeds with empty buffer" $+                forAll genUnchecked $ \sets -> do+                    let zf = mempty :: Zift ()+                    (zr, zs) <- runZiftTest sets zf+                    zr `shouldBe` ZiftSuccess ()+                    zs `shouldBe` ZiftState {bufferedOutput = []}+            describe "mappend" $+                it+                    "succeeds with empty buffers but with the output in the channel" $+                forAll genUnchecked $ \sets ->+                    forAll genUnchecked $ \zo1 ->+                        forAll genUnchecked $ \zo2 -> do+                            let zf1 =+                                    Zift $ \_ _ ->+                                        pure+                                            ( ZiftSuccess ()+                                            , ZiftState {bufferedOutput = [zo1]})+                            let zf2 =+                                    Zift $ \_ _ ->+                                        pure+                                            ( ZiftSuccess ()+                                            , ZiftState {bufferedOutput = [zo2]})+                            let zf = zf1 `mappend` zf2+                            pchan <- atomically newTChan+                            (zr, zs) <- runZiftTestWithChan pchan sets zf+                            zr `shouldBe` ZiftSuccess ()+                            zs `shouldBe` ZiftState {bufferedOutput = []}+                            atomically (readTChan pchan) `shouldReturn` zo1+                            atomically (readTChan pchan) `shouldReturn` zo2+        describe "Functor Zift" $+            describe "fmap" $+            it "it succeeds with a flushed buffer" $+            forAll genUnchecked $ \sets ->+                forAll genUnchecked $ \state -> do+                    let zf =+                            fmap (+ 1) $+                            Zift $ \_ st -> pure (ZiftSuccess (0 :: Int), st)+                    pchan <- atomically newTChan+                    (zr, zs) <- runZiftTestWith state pchan sets zf+                    zr `shouldBe` ZiftSuccess 1+                    zs `shouldBe` ZiftState {bufferedOutput = []}+                    buffer <- readAllFrom pchan+                    buffer `shouldBe` reverse (bufferedOutput state)+        describe "Applicative Zift" $ do+            describe "pure" $+                it "succeeds with the same state" $+                forAll genUnchecked $ \sets ->+                    forAll genUnchecked $ \state -> do+                        let zf = pure () :: Zift ()+                        (zr, zs) <- runZiftTestWithState state sets zf+                        zr `shouldBe` ZiftSuccess ()+                        zs `shouldBe` state+            describe "<*>" $+                it "succeeds with a linear flushed buffer" $+                forAll genUnchecked $ \sets ->+                    forAll genUnchecked $ \state ->+                        forAll genUnchecked $ \st1 ->+                            forAll genUnchecked $ \st2 -> do+                                let zf1 =+                                        Zift $ \_ st ->+                                            pure+                                                ( ZiftSuccess (+ 1)+                                                , st `mappend` st1)+                                let zf2 =+                                        Zift $ \_ st ->+                                            pure+                                                ( ZiftSuccess (1 :: Int)+                                                , st `mappend` st2)+                                let zf = zf1 <*> zf2+                                pchan <- atomically newTChan+                                (zr, zs) <- runZiftTestWith state pchan sets zf+                                zr `shouldBe` ZiftSuccess 2+                                zs `shouldBe` ZiftState {bufferedOutput = []}+                                buffer <- readAllFrom pchan+                                buffer `shouldBe`+                                    reverse+                                        (bufferedOutput st2 +++                                         bufferedOutput st1 +++                                         bufferedOutput state)+        describe "Monad Zift" $+            describe ">>=" $+            it "succeeds with a flushed buffer after the first output" $+            forAll genUnchecked $ \sets ->+                forAll genUnchecked $ \state ->+                    forAll genUnchecked $ \zo1 ->+                        forAll genUnchecked $ \zo2 -> do+                            let zf1 =+                                    Zift $ \_ st ->+                                        pure+                                            ( ZiftSuccess (2 :: Int)+                                            , st+                                              { bufferedOutput =+                                                    zo1 : bufferedOutput st+                                              })+                            let zf2 n =+                                    Zift $ \_ st ->+                                        pure+                                            ( ZiftSuccess (n + 1)+                                            , st+                                              { bufferedOutput =+                                                    zo2 : bufferedOutput st+                                              })+                            let zf = zf1 >>= zf2+                            pchan <- atomically newTChan+                            (zr, zs) <- runZiftTestWith state pchan sets zf+                            zr `shouldBe` ZiftSuccess 3+                            zs `shouldBe` ZiftState {bufferedOutput = [zo2]}+                            buffer <- readAllFrom pchan+                            buffer `shouldBe`+                                (reverse (bufferedOutput state) ++ [zo1])+        describe "MonadFail Zift" $ do+            describe "fail" $+                it "just results in a ZiftFailed" $+                forAll genUnchecked $ \sets ->+                    forAll genUnchecked $ \state -> do+                        let s = "Test"+                        let zf = fail s :: Zift ()+                        (zr, zs) <- runZiftTestWithState state sets zf+                        zr `shouldBe` ZiftFailed s+                        zs `shouldBe` state+            describe "liftIO . fail" $+                it "just returns ZiftFailed" $+                forAll genUnchecked $ \sets ->+                    forAll genUnchecked $ \state -> do+                        let s = "Test"+                        let zf = liftIO $ fail s :: Zift ()+                        (zr, zs) <- runZiftTestWithState state sets zf+                        zr `shouldBe` ZiftFailed ("user error (" ++ s ++ ")")+                        zs `shouldBe` state++runZiftTest :: Settings -> Zift a -> IO (ZiftResult a, ZiftState)+runZiftTest sets func = do+    pchan <- atomically newTChan+    runZiftTestWithChan pchan sets func++runZiftTestWithChan :: TChan ZiftOutput+                    -> Settings+                    -> Zift a+                    -> IO (ZiftResult a, ZiftState)+runZiftTestWithChan = runZiftTestWith ZiftState {bufferedOutput = []}++runZiftTestWithState :: ZiftState+                     -> Settings+                     -> Zift a+                     -> IO (ZiftResult a, ZiftState)+runZiftTestWithState state sets func = do+    pchan <- atomically newTChan+    runZiftTestWith state pchan sets func++runZiftTestWith+    :: ZiftState+    -> TChan ZiftOutput+    -> Settings+    -> Zift a+    -> IO (ZiftResult a, ZiftState)+runZiftTestWith zs pchan sets func = do+    rd <- getCurrentDir+    let zc =+            ZiftContext+            { rootdir = rd+            , settings = sets+            , printChan = pchan+            , recursionList = []+            }+    zift func zc zs++readAllFrom :: TChan a -> IO [a]+readAllFrom chan = do+    mr <- atomically $ tryReadTChan chan+    case mr of+        Nothing -> pure []+        Just r -> do+            rest <- readAllFrom chan+            pure (r : rest)
+ zifter.cabal view
@@ -0,0 +1,67 @@+name: zifter+description: zifter+synopsis: zifter+version: 0.0.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+copyright: Copyright: (c) 2017 Tom Sydney Kerckhove+maintainer: syd.kerckhove@gmail.com+homepage: http://cs-syd.eu+category: Zift+author: Tom Sydney Kerckhove++library+    exposed-modules:+        Zifter+        Zifter.OptParse+        Zifter.OptParse.Types+        Zifter.Recurse+        Zifter.Script+        Zifter.Script.Types+        Zifter.Setup+        Zifter.Setup.Types+        Zifter.Types+        Zifter.Zift+        Zifter.Zift.Types+    build-depends:+        base >=4.9 && <=5,+        async >=2.1 && <2.2,+        directory >=1.3 && <1.4,+        exceptions >=0.8 && <0.9,+        filepath >=1.4 && <1.5,+        optparse-applicative >=0.13 && <0.14,+        path >=0.5 && <0.6,+        path-io >1.2 && <1.3,+        process >=1.4 && <1.6,+        safe >=0.3 && <0.4,+        validity >=0.3 && <0.4,+        stm >=2.4 && <2.5,+        ansi-terminal >=0.6 && <0.7,+        validity-path >= 0.1 && < 0.2+    default-language: Haskell2010+    hs-source-dirs: src/+    ghc-options: -Wall++test-suite zifter-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-depends:+        base >=4.9 && <=5,+        zifter -any,+        QuickCheck >= 2.8 && < 2.9,+        genvalidity >=0.3 && <0.4,+        genvalidity-hspec >=0.3 && <0.4,+        hspec -any,+        path -any,+        path-io -any,+        stm -any,+        ansi-terminal+    default-language: Haskell2010+    hs-source-dirs: test/+    other-modules:+        Zifter.ZiftSpec+        Zifter.Zift.Gen+        Zifter.OptParse.Gen+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall