shake 0.17.9 → 0.18
raw patch · 18 files changed
+281/−119 lines, 18 filesdep ~basedep ~directory
Dependency ranges changed: base, directory
Files
- CHANGES.txt +6/−0
- shake.cabal +2/−2
- src/Development/Shake/Command.hs +2/−1
- src/Development/Shake/Internal/Args.hs +11/−8
- src/Development/Shake/Internal/Core/Build.hs +14/−12
- src/Development/Shake/Internal/Core/Monad.hs +108/−50
- src/Development/Shake/Internal/Core/Run.hs +2/−1
- src/Development/Shake/Internal/Core/Types.hs +12/−3
- src/Development/Shake/Internal/Derived.hs +13/−8
- src/Development/Shake/Internal/History/Shared.hs +1/−1
- src/Development/Shake/Internal/History/Symlink.hs +4/−5
- src/General/Extra.hs +14/−1
- src/General/ListBuilder.hs +35/−19
- src/Test/Docs.hs +3/−2
- src/Test/History.hs +2/−1
- src/Test/Monad.hs +4/−4
- src/Test/Parallel.hs +47/−0
- src/Test/Type.hs +1/−1
CHANGES.txt view
@@ -1,5 +1,11 @@ Changelog for Shake (* = breaking change) +0.18, released 2019-05-14+* Make files copied to the shared cache read-only+ Delete files before writing, giving symlink/readonly safety+ #677, make --help work even if the build system throws errors+* Use parallelism for Applicative adjacent needs+ Support GHC 8.8 0.17.9, released 2019-05-01 #675, allow --compact=yes|no|auto Make lintTrackAllow work after the lintTrackRead/Write
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: shake-version: 0.17.9+version: 0.18 license: BSD3 license-file: LICENSE category: Development, Shake@@ -84,7 +84,7 @@ binary, bytestring, deepseq >= 1.1,- directory,+ directory >= 1.2.7.0, extra >= 1.6.14, filepath, filepattern,
src/Development/Shake/Command.hs view
@@ -21,6 +21,7 @@ import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.IO.Class+import Control.Exception.Extra import Data.Char import Data.Either.Extra import Data.List.Extra@@ -190,7 +191,7 @@ | not $ isFSATrace params = call params | ResultProcess PID0 `elem` results = -- This is a bad state to get into, you could technically just ignore the tracing, but that's a bit dangerous- fail "Asyncronous process execution combined with FSATrace is not support"+ liftIO $ errorIO "Asyncronous process execution combined with FSATrace is not support" | otherwise = runWithTempDir $ \dir -> do let file = dir </> "fsatrace.txt" liftIO $ writeFile file "" -- ensures even if we fail before fsatrace opens the file, we can still read it
src/Development/Shake/Internal/Args.hs view
@@ -19,11 +19,13 @@ import Development.Shake.Internal.Progress import Development.Shake.Database import General.Timing+import General.Extra import General.Thread import General.GetOpt import General.EscCodes import Data.Tuple.Extra+import Control.DeepSeq import Control.Exception.Extra import Control.Monad import Data.Either@@ -158,14 +160,15 @@ let putWhenLn v msg = putWhen v $ msg ++ "\n" let showHelp long = do progName <- getProgName- targets <- if not long then return [] else do- -- run the rules as simply as we can- rs <- rules shakeOpts [] []- case rs of- Just (_, rs) -> do- xs <- getTargets shakeOpts rs- return [" - " ++ a ++ maybe "" (" - " ++) b | (a,b) <- xs]- _ -> return []+ targets <- if not long then return [] else+ handleSynchronous (\e -> do putWhenLn Normal $ "Failure to collect targets: " ++ show e; return []) $ do+ -- run the rules as simply as we can+ rs <- rules shakeOpts [] []+ case rs of+ Just (_, rs) -> do+ xs <- getTargets shakeOpts rs+ evaluate $ force [" - " ++ a ++ maybe "" (" - " ++) b | (a,b) <- xs]+ _ -> return [] changes <- return $ let as = shakeOptionsFields baseOpts bs = shakeOptionsFields oshakeOpts
src/Development/Shake/Internal/Core/Build.hs view
@@ -4,6 +4,7 @@ module Development.Shake.Internal.Core.Build( getDatabaseValue, getDatabaseValueGeneric, historyIsEnabled, historySave, historyLoad,+ applyKeyValue, apply, apply1, ) where @@ -141,12 +142,18 @@ -- ACTUAL WORKERS applyKeyValue :: [String] -> [Key] -> Action [Value]-applyKeyValue _ [] = return [] applyKeyValue callStack ks = do+ -- this is the only place a user can inject a key into our world, so check they aren't throwing+ -- in unevaluated bottoms+ liftIO $ mapM_ (evaluate . rnf) ks+ global@Global{..} <- Action getRO- Local{localStack} <- Action getRW+ Local{localStack, localBlockApply} <- Action getRW let stack = addCallStack callStack localStack + let tk = typeKey $ head $ ks ++ [newKey ()] -- always called at non-empty so never see () key+ whenJust localBlockApply $ throwM . errorNoApply tk (show <$> listToMaybe ks)+ let database = globalDatabase (is, wait) <- liftIO $ runLocked database $ do is <- mapM (mkId database) ks@@ -223,16 +230,11 @@ -- This function requires that appropriate rules have been added with 'addBuiltinRule'. -- All @key@ values passed to 'apply' become dependencies of the 'Action'. apply :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]--- Don't short-circuit [] as we still want error messages-apply ks = do- -- this is the only place a user can inject a key into our world, so check they aren't throwing- -- in unevaluated bottoms- liftIO $ mapM_ (evaluate . rnf) ks-- let tk = typeRep ks- Local{localBlockApply} <- Action getRW- whenJust localBlockApply $ throwM . errorNoApply tk (show <$> listToMaybe ks)- fmap (map fromValue) $ applyKeyValue callStackFull $ map newKey ks+apply [] =+ -- if they do [] then we don't test localBlockApply, but unclear if that should be an error or not+ return []+apply ks =+ fmap (map fromValue) $ Action $ stepRAW (callStackFull, map newKey ks) -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,
src/Development/Shake/Internal/Core/Monad.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections, GeneralizedNewtypeDeriving #-} module Development.Shake.Internal.Core.Monad( RAW, Capture, runRAW, getRO, getRW, putRW, modifyRW,+ stepRAW, catchRAW, tryRAW, throwRAW, finallyRAW, captureRAW, ) where import Control.Exception.Extra+import Development.Shake.Internal.Errors import Control.Monad.IO.Class import Data.IORef import Control.Monad@@ -21,45 +23,46 @@ #endif -data RAW ro rw a where- Fmap :: (a -> b) -> RAW ro rw a -> RAW ro rw b- Pure :: a -> RAW ro rw a- Ap :: RAW ro rw (a -> b) -> RAW ro rw a -> RAW ro rw b- Next :: RAW ro rw a -> RAW ro rw b -> RAW ro rw b- Bind :: RAW ro rw a -> (a -> RAW ro rw b) -> RAW ro rw b- LiftIO :: IO a -> RAW ro rw a- GetRO :: RAW ro rw ro- GetRW :: RAW ro rw rw- PutRW :: !rw -> RAW ro rw ()- ModifyRW :: (rw -> rw) -> RAW ro rw ()- CaptureRAW :: Capture (Either SomeException a) -> RAW ro rw a- CatchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a+data RAW k v ro rw a where+ Fmap :: (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b+ Pure :: a -> RAW k v ro rw a+ Ap :: RAW k v ro rw (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b+ Next :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b+ Bind :: RAW k v ro rw a -> (a -> RAW k v ro rw b) -> RAW k v ro rw b+ LiftIO :: IO a -> RAW k v ro rw a+ GetRO :: RAW k v ro rw ro+ GetRW :: RAW k v ro rw rw+ PutRW :: !rw -> RAW k v ro rw ()+ ModifyRW :: (rw -> rw) -> RAW k v ro rw ()+ StepRAW :: k -> RAW k v ro rw v+ CaptureRAW :: Capture (Either SomeException a) -> RAW k v ro rw a+ CatchRAW :: RAW k v ro rw a -> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a -instance Functor (RAW ro rw) where+instance Functor (RAW k v ro rw) where fmap = Fmap -instance Applicative (RAW ro rw) where+instance Applicative (RAW k v ro rw) where pure = Pure (*>) = Next (<*>) = Ap -instance Monad (RAW ro rw) where+instance Monad (RAW k v ro rw) where return = pure (>>) = (*>) (>>=) = Bind -instance MonadIO (RAW ro rw) where+instance MonadIO (RAW k v ro rw) where liftIO = LiftIO #if __GLASGOW_HASKELL__ >= 800-instance MonadFail (RAW ro rw) where+instance MonadFail (RAW k v ro rw) where fail = liftIO . Control.Monad.Fail.fail #endif -instance Semigroup a => Semigroup (RAW ro rw a) where+instance Semigroup a => Semigroup (RAW k v ro rw a) where (<>) a b = (<>) <$> a <*> b -instance (Semigroup a, Monoid a) => Monoid (RAW ro rw a) where+instance (Semigroup a, Monoid a) => Monoid (RAW k v ro rw a) where mempty = pure mempty mappend = (<>) @@ -84,48 +87,66 @@ k v -- | Run and then call a continuation.-runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)-runRAW ro rw m k = do+runRAW :: ([k] -> RAW k v ro rw [v]) -> ro -> rw -> RAW k v ro rw a -> Capture (Either SomeException a)+runRAW step ro rw m k = do k <- assertOnce "runRAW" k rw <- newIORef rw handler <- newIORef throwIO+ steps <- newSteps writeIORef handler $ \e -> do -- make sure we never call the error continuation twice writeIORef handler throwIO k $ Left e -- If the continuation itself throws an error we need to make sure we -- don't end up running it twice (once with its result, once with its own exception)- goRAW handler ro rw m (\v -> do writeIORef handler throwIO; k $ Right v)+ goRAW step steps handler ro rw m (\v -> do writeIORef handler throwIO; k $ Right v) `catch_` \e -> ($ e) =<< readIORef handler -goRAW :: forall ro rw a . IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW ro rw a -> Capture a-goRAW handler ro rw = go+goRAW :: forall k v ro rw a . ([k] -> RAW k v ro rw [v]) -> Steps k v -> IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW k v ro rw a -> Capture a+goRAW step steps handler ro rw = \x k -> go x $ \v -> sio v k where- go :: RAW ro rw b -> Capture b+ sio :: SIO b -> Capture b+ sio (SIO v) k = flush $ do v <- v; k v++ flush :: IO () -> IO ()+ flush k = do+ v <- flushSteps steps+ case v of+ Nothing -> k+ Just f -> go (f step) $ const k++ unflush :: IO ()+ unflush = unflushSteps steps++ go :: RAW k v ro rw b -> Capture (SIO b) go x k = case x of- Fmap f a -> go a $ \v -> k $ f v- Pure a -> k a- Ap f x -> go f $ \f -> go x $ \v -> k $ f v- Bind a b -> go a $ \a -> go (b a) k- Next a b -> go a $ \_ -> go b k- LiftIO x -> k =<< x+ Fmap f a -> go a $ \v -> k $ fmap f v+ Pure a -> k $ pure a+ Ap f x -> go f $ \f -> go x $ \v -> k $ f <*> v+ Next a b -> go a $ \a -> go b $ \b -> k $ a *> b+ StepRAW q -> do+ v <- addStep steps q+ k v - GetRO -> k ro- GetRW -> k =<< readIORef rw- PutRW x -> writeIORef rw x >> k ()- ModifyRW f -> modifyIORef' rw f >> k ()+ Bind a b -> go a $ \a -> sio a $ \a -> go (b a) k+ LiftIO act -> flush $ do v <- act; k $ pure v - CatchRAW m hdl -> do+ GetRO -> k $ return ro+ GetRW -> flush $ k . return =<< readIORef rw+ PutRW x -> flush $ writeIORef rw x >> k (return ())+ ModifyRW f -> flush $ modifyIORef' rw f >> k (return ())++ CatchRAW m hdl -> flush $ do hdl <- assertOnce "CatchRAW" hdl old <- readIORef handler writeIORef handler $ \e -> do writeIORef handler old go (hdl e) k `catch_`- \e -> ($ e) =<< readIORef handler+ \e -> do unflush; ($ e) =<< readIORef handler go m $ \x -> writeIORef handler old >> k x - CaptureRAW f -> do+ CaptureRAW f -> flush $ do f <- assertOnce "CaptureRAW" f old <- readIORef handler writeIORef handler throwIO@@ -133,41 +154,71 @@ Left e -> old e Right v -> do writeIORef handler old- k v `catch_` \e -> ($ e) =<< readIORef handler+ k (return v) `catch_` \e -> do unflush; ($ e) =<< readIORef handler +newtype SIO a = SIO (IO a)+ deriving (Functor, Monad, Applicative)+++newtype Steps k v = Steps (IORef [(k, IORef v)])++newSteps :: IO (Steps k v)+newSteps = Steps <$> newIORef []++addStep :: Steps k v -> k -> IO (SIO v)+addStep (Steps ref) k = do+ out <- newIORef $ throwImpure $ errorInternal "Monad, addStep not flushed"+ modifyIORef ref ((k,out):)+ return $ SIO $ readIORef out++unflushSteps :: Steps k v -> IO ()+unflushSteps (Steps ref) = writeIORef ref []++flushSteps :: MonadIO m => Steps k v -> IO (Maybe (([k] -> m [v]) -> m ()))+flushSteps (Steps ref) = do+ v <- reverse <$> readIORef ref+ case v of+ [] -> return Nothing+ xs -> do+ writeIORef ref []+ return $ Just $ \step -> do+ vs <- step $ map fst xs+ liftIO $ zipWithM_ writeIORef (map snd xs) vs++ --------------------------------------------------------------------- -- STANDARD -getRO :: RAW ro rw ro+getRO :: RAW k v ro rw ro getRO = GetRO -getRW :: RAW ro rw rw+getRW :: RAW k v ro rw rw getRW = GetRW -- | Strict version-putRW :: rw -> RAW ro rw ()+putRW :: rw -> RAW k v ro rw () putRW = PutRW -modifyRW :: (rw -> rw) -> RAW ro rw ()+modifyRW :: (rw -> rw) -> RAW k v ro rw () modifyRW = ModifyRW --------------------------------------------------------------------- -- EXCEPTIONS -catchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a+catchRAW :: RAW k v ro rw a -> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a catchRAW = CatchRAW -tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a)+tryRAW :: RAW k v ro rw a -> RAW k v ro rw (Either SomeException a) tryRAW m = catchRAW (fmap Right m) (return . Left) -throwRAW :: Exception e => e -> RAW ro rw a+throwRAW :: Exception e => e -> RAW k v ro rw a -- Note that while we could directly pass this to the handler -- that would avoid triggering the catch, which would mean they built up on the stack throwRAW = liftIO . throwIO -finallyRAW :: RAW ro rw a -> RAW ro rw b -> RAW ro rw a+finallyRAW :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw a finallyRAW a undo = do r <- catchRAW a (\e -> undo >> throwRAW e) undo@@ -179,5 +230,12 @@ -- | Capture a continuation. The continuation should be called at most once. -- Calling the same continuation, multiple times, in parallel, results in incorrect behaviour.-captureRAW :: Capture (Either SomeException a) -> RAW ro rw a+captureRAW :: Capture (Either SomeException a) -> RAW k v ro rw a captureRAW = CaptureRAW+++---------------------------------------------------------------------+-- STEPS++stepRAW :: k -> RAW k v ro rw v+stepRAW = StepRAW
src/Development/Shake/Internal/Core/Run.hs view
@@ -21,6 +21,7 @@ import General.Binary import Development.Shake.Classes import Development.Shake.Internal.Core.Storage+import Development.Shake.Internal.Core.Build import Development.Shake.Internal.History.Shared import Development.Shake.Internal.History.Cloud import qualified General.TypeMap as TMap@@ -140,7 +141,7 @@ addTiming "Running rules" locals <- newIORef [] runPool (shakeThreads == 1) shakeThreads $ \pool -> do- let global = Global database pool cleanup start ruleinfo output opts diagnostic ruleFinished after absent getProgress userRules shared cloud step oneshot+ let global = Global applyKeyValue database pool cleanup start ruleinfo output opts diagnostic ruleFinished after absent getProgress userRules shared cloud step oneshot -- give each action a stack to start with! forM_ (actions ++ map (emptyStack,) actions2) $ \(stack, act) -> do let local = newLocal stack shakeVerbosity
src/Development/Shake/Internal/Core/Types.hs view
@@ -60,7 +60,7 @@ -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files. -- Action values are used by 'addUserRule' and 'action'. The 'Action' monad tracks the dependencies of a rule. -- To raise an exception call 'error', 'fail' or @'liftIO' . 'throwIO'@.-newtype Action a = Action {fromAction :: RAW Global Local a}+newtype Action a = Action {fromAction :: RAW ([String],[Key]) [Value] Global Local a} deriving (Functor, Applicative, Monad, MonadIO, Typeable, Semigroup, Monoid #if __GLASGOW_HASKELL__ >= 800 ,MonadFail@@ -68,7 +68,15 @@ ) runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)-runAction g l (Action x) = runRAW g l x+runAction g l (Action x) = runRAW (fromAction . build) g l x+ where+ -- first argument is a list of call stacks, since build only takes one we use the first+ -- they are very probably all identical...+ build :: [([String], [Key])] -> Action [[Value]]+ build [] = return []+ build ks@((callstack,_):_) = do+ let kss = map snd ks+ unconcat kss <$> globalBuild g callstack (concat kss) ---------------------------------------------------------------------@@ -386,7 +394,8 @@ -- global constants of Action data Global = Global- {globalDatabase :: Database -- ^ Database, contains knowledge of the state of each key+ {globalBuild :: [String] -> [Key] -> Action [Value]+ ,globalDatabase :: Database -- ^ Database, contains knowledge of the state of each key ,globalPool :: Pool -- ^ Pool, for queuing new elements ,globalCleanup :: Cleanup -- ^ Cleanup operations ,globalTimestamp :: IO Seconds -- ^ Clock saying how many seconds through the build
src/Development/Shake/Internal/Derived.hs view
@@ -87,18 +87,19 @@ -- | @copyFile' old new@ copies the existing file from @old@ to @new@. -- The @old@ file will be tracked as a dependency. -- Also creates the new directory if necessary.-copyFile' :: FilePath -> FilePath -> Action ()+copyFile' :: Partial => FilePath -> FilePath -> Action () copyFile' old new = do need [old] putLoud $ "Copying from " ++ old ++ " to " ++ new liftIO $ do createDirectoryRecursive $ takeDirectory new+ removeFile_ new -- symlink safety copyFile old new -- | @copyFileChanged old new@ copies the existing file from @old@ to @new@, if the contents have changed. -- The @old@ file will be tracked as a dependency. -- Also creates the new directory if necessary.-copyFileChanged :: FilePath -> FilePath -> Action ()+copyFileChanged :: Partial => FilePath -> FilePath -> Action () copyFileChanged old new = do need [old] -- in newer versions of the directory package we can use copyFileWithMetadata which (we think) updates@@ -108,32 +109,34 @@ liftIO $ do createDirectoryRecursive $ takeDirectory new -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it+ removeFile_ new -- symlink safety liftIO $ copyFile old new -- | Read a file, after calling 'need'. The argument file will be tracked as a dependency.-readFile' :: FilePath -> Action String+readFile' :: Partial => FilePath -> Action String readFile' x = need [x] >> liftIO (readFile x) -- | Write a file, lifted to the 'Action' monad.-writeFile' :: MonadIO m => FilePath -> String -> m ()+writeFile' :: (MonadIO m, Partial) => FilePath -> String -> m () writeFile' name x = liftIO $ do createDirectoryRecursive $ takeDirectory name+ removeFile_ x -- symlink safety writeFile name x -- | A version of 'readFile'' which also splits the result into lines. -- The argument file will be tracked as a dependency.-readFileLines :: FilePath -> Action [String]+readFileLines :: Partial => FilePath -> Action [String] readFileLines = fmap lines . readFile' -- | A version of 'writeFile'' which writes out a list of lines.-writeFileLines :: MonadIO m => FilePath -> [String] -> m ()+writeFileLines :: (MonadIO m, Partial) => FilePath -> [String] -> m () writeFileLines name = writeFile' name . unlines -- | Write a file, but only if the contents would change.-writeFileChanged :: MonadIO m => FilePath -> String -> m ()+writeFileChanged :: (MonadIO m, Partial) => FilePath -> String -> m () writeFileChanged name x = liftIO $ do createDirectoryRecursive $ takeDirectory name b <- doesFileExist name@@ -143,7 +146,9 @@ b <- withFile name ReadMode $ \h -> do src <- hGetContents h return $! src /= x- when b $ writeFile name x+ when b $ do+ removeFile_ x -- symlink safety+ writeFile name x -- | Create a temporary file in the temporary directory. The file will be deleted
@@ -150,7 +150,7 @@ -- if any key matches, clean them all out b <- flip anyM files $ \file -> handleSynchronous (\e -> putStrLn ("Warning: " ++ show e) >> return False) $ evaluate . test . entryKey . getEntry keyOp =<< BS.readFile file- when b $ removeDirectoryRecursive dir+ when b $ removePathForcibly dir return b liftIO $ putStrLn $ "Deleted " ++ show (length (filter id deleted)) ++ " entries"
src/Development/Shake/Internal/History/Symlink.hs view
@@ -47,8 +47,7 @@ b <- createLinkBool from to whenJust b $ \_ -> copyFile from to- -- making files read only stops them from easily deleting- when False $- forM_ [from, to] $ \x -> do- perm <- getPermissions x- setPermissions x perm{writable=False}+ -- making files read only stops them from inadvertantly mutating the cache+ forM_ [from, to] $ \x -> do+ perm <- getPermissions x+ setPermissions x perm{writable=False}
src/General/Extra.hs view
@@ -9,6 +9,7 @@ wrapQuote, showBracket, withs, forNothingM, maximum', maximumBy',+ unconcat, fastAt, zipExact, zipWithExact, isAsyncException,@@ -32,6 +33,7 @@ import Control.DeepSeq import General.Cleanup import Data.Typeable+import System.IO.Error import System.IO.Extra import System.Time.Extra import System.IO.Unsafe@@ -66,7 +68,12 @@ newtype NoShow a = NoShow a instance Show (NoShow a) where show _ = "NoShow" +unconcat :: [[a]] -> [b] -> [[b]]+unconcat [] _ = []+unconcat (a:as) bs = b1 : unconcat as b2+ where (b1,b2) = splitAt (length a) bs + --------------------------------------------------------------------- -- Data.List @@ -235,7 +242,13 @@ -- | Remove a file, but don't worry if it fails removeFile_ :: FilePath -> IO ()-removeFile_ x = removeFile x `catchIO` \_ -> return ()+removeFile_ x =+ removeFile x `catchIO` \e ->+ when (isPermissionError e) $ handleIO (\_ -> return ()) $ do+ perms <- getPermissions x+ setPermissions x perms{readable = True, searchable = True, writable = True}+ removeFile x+ -- | Like @createDirectoryIfMissing True@ but faster, as it avoids -- any work in the common case the directory already exists.
src/General/ListBuilder.hs view
@@ -1,34 +1,50 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} module General.ListBuilder(- ListBuilder, runListBuilder, newListBuilder+ ListBuilder, runListBuilder, newListBuilder,+ Tree(..), flattenTree, unflattenTree ) where import Data.Semigroup (Semigroup (..)) +-- ListBuilder is opaque outside this module+newtype ListBuilder a = ListBuilder (Tree a)+ deriving (Semigroup, Monoid, Functor) -data ListBuilder a- = Zero- | One a- | Add (ListBuilder a) (ListBuilder a)- deriving Functor+data Tree a+ = Empty+ | Leaf a+ | Branch (Tree a) (Tree a)+ deriving (Functor,Eq,Ord,Show) -instance Semigroup (ListBuilder a) where- Zero <> x = x- x <> Zero = x- x <> y = Add x y+instance Semigroup (Tree a) where+ Empty <> x = x+ x <> Empty = x+ x <> y = Branch x y -instance Monoid (ListBuilder a) where- mempty = Zero+instance Monoid (Tree a) where+ mempty = Empty mappend = (<>) +flattenTree :: Tree a -> [a]+flattenTree x = f x []+ where+ f Empty acc = acc+ f (Leaf x) acc = x : acc+ f (Branch x y) acc = f x (f y acc)++unflattenTree :: Tree a -> [b] -> Tree b+unflattenTree t xs = fst $ f t xs+ where+ f Empty xs = (Empty, xs)+ f Leaf{} (x:xs) = (Leaf x, xs)+ f (Branch a b) xs = (Branch a2 b2, xs3)+ where (a2, xs2) = f a xs+ (b2, xs3) = f b xs2+ newListBuilder :: a -> ListBuilder a-newListBuilder = One+newListBuilder = ListBuilder . Leaf runListBuilder :: ListBuilder a -> [a]-runListBuilder x = f x []- where- f Zero acc = acc- f (One x) acc = x : acc- f (Add x y) acc = f x (f y acc)+runListBuilder (ListBuilder x) = flattenTree x
src/Test/Docs.hs view
@@ -4,6 +4,7 @@ import Development.Shake import Development.Shake.FilePath+import qualified System.FilePattern.Directory as IO import System.Directory import Test.Type import Control.Monad@@ -143,7 +144,7 @@ "Files.lst" %> \out -> do need [shakeRoot </> "src/Test/Docs.hs"] -- so much of the generator is in this module need [index]- filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]+ filesHs <- liftIO $ IO.getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"] -- filesMd on Travis will only include Manual.md, since it's the only one listed in the .cabal -- On AppVeyor, where we build from source, it will check the rest of the website filesMd <- getDirectoryFiles (shakeRoot </> "docs") ["*.md"]@@ -334,7 +335,7 @@ whitelist x | elem x $ words $ "newtype do a q m c x value key os contents clean _make " ++ ".. /. // \\ //* dir/*/* dir [ " ++- "ConstraintKinds TemplateHaskell OverloadedLists OverloadedStrings GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " +++ "ConstraintKinds TemplateHaskell ApplicativeDo OverloadedLists OverloadedStrings GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " ++ "Data.List System.Directory Development.Shake.FilePath run " ++ "NoProgress Error src about://tracing " ++ ".make/i586-linux-gcc/output build " ++
src/Test/History.hs view
@@ -4,6 +4,7 @@ import Development.Shake import Test.Type+import General.Extra import General.GetOpt import System.Directory @@ -51,7 +52,7 @@ checkOut "1" setIn "2"- mapM_ removeFile outs+ mapM_ removeFile_ outs build $ ["--die","--share"] ++ outs checkOut "2"
src/Test/Monad.hs view
@@ -14,10 +14,10 @@ -run :: ro -> rw -> RAW ro rw a -> IO a+run :: ro -> rw -> RAW () () ro rw a -> IO a run ro rw m = do res <- newEmptyMVar- runRAW ro rw m $ void . tryPutMVar res+ runRAW return ro rw m $ void . tryPutMVar res either throwIO return =<< readMVar res @@ -74,7 +74,7 @@ return "x" res === Left Overflow -- test for GHC bug 11555- runRAW 1 "test" (throw Overflow :: RAW Int String ()) $ \res ->+ runRAW return 1 "test" (throw Overflow :: RAW () () Int String ()) $ \res -> mapLeft fromException res === Left (Just Overflow) -- catch works properly if continuation called multiple times@@ -92,7 +92,7 @@ -- what if we throw an exception inside the continuation of run ref <- newIORef 0- res <- try $ runRAW 1 "test" (return 1) $ \_ -> do+ res <- try $ runRAW return 1 "test" (return 1) $ \_ -> do modifyIORef ref (+1) throwIO Overflow res === Left Overflow
src/Test/Parallel.hs view
@@ -3,6 +3,7 @@ import Development.Shake import Test.Type+import Data.Foldable import Data.Tuple.Extra import Control.Monad import Control.Concurrent.Extra@@ -15,6 +16,46 @@ (text1,text2) <- readFile' "A.txt" `par` readFile' "B.txt" writeFile' out $ text1 ++ text2 ++ sem <- liftIO $ newQSemN 0+ "papplicative_*" %> \out -> do+ -- wait for both to do the initial start before continuing+ liftIO $ assertWithin 1 $ do+ signalQSemN sem 1+ waitQSemN sem 3+ signalQSemN sem 3+ writeFile' out ""++ phony "papplicative" $ do+ need ["papplicative_1"]+ need ["papplicative_2"]+ let ensureReturn = return ()+ ensureReturn -- should work even though we have a return+ need ["papplicative_3"]++ "pseparate_*" %> \out -> do+ liftIO $ appendFile "pseparate.log" "["+ liftIO $ sleep 0.1+ liftIO $ appendFile "pseparate.log" "]"+ writeFile' out ""++ phony "pseparate" $ do+ need ["pseparate_1"]+ liftIO $ return ()+ need ["pseparate_2"]++ sem <- liftIO $ newQSemN 0+ "ptraverse_*" %> \out -> do+ -- wait for all to do the initial start before continuing+ liftIO $ assertWithin 1 $ do+ signalQSemN sem 1+ waitQSemN sem 8+ signalQSemN sem 8+ writeFile' out ""++ phony "ptraverse" $+ traverse_ (need . pure) ["ptraverse_" ++ show i | i <- [1..8]]+ phony "cancel" $ do writeFile' "cancel" "" done <- liftIO $ newIORef 0@@ -59,3 +100,9 @@ build ["parallels"] assertContents "parallels" $ show $ replicate 5 [1..5]++ writeFile "pseparate.log" ""+ build ["pseparate","-j2"]+ assertContents "pseparate.log" "[][]"+ build ["papplicative","-j3"]+ build ["ptraverse","-j8"]
src/Test/Type.hs view
@@ -80,7 +80,7 @@ when (takeBaseName now /= name) $ fail $ "Clean went horribly wrong! Dangerous deleting: " ++ show now withCurrentDirectory (now </> "..") $ do- removeDirectoryRecursive now+ removePathForcibly now createDirectoryRecursive now unless reenter $ createDirectoryRecursive out case args of