shake 0.18.2 → 0.18.3

raw patch · 17 files changed

+108/−66 lines, 17 files

Files

• CHANGES.txt +3/−0
• shake.cabal +1/−1
• src/Development/Shake/Internal/Args.hs +3/−1
• src/Development/Shake/Internal/Core/Rules.hs +2/−1
• src/Development/Shake/Internal/Core/Run.hs +2/−2
• src/Development/Shake/Internal/History/Shared.hs +5/−4
• src/Development/Shake/Internal/History/Symlink.hs +15/−13
• src/Development/Shake/Internal/Options.hs +9/−7
• src/General/Bilist.hs +2/−1
• src/General/Binary.hs +2/−1
• src/General/ListBuilder.hs +3/−1
• src/General/Process.hs +15/−4
• src/General/TypeMap.hs +1/−1
• src/Test/Command.hs +7/−0
• src/Test/Docs.hs +5/−5
• src/Test/History.hs +32/−23
• src/Test/Self.hs +1/−1

@@ -1,5 +1,8 @@ Changelog for Shake (* = breaking change) +0.18.3, released 2019-07-01+    Add shakeSymlink to enable/disable symlinks in the shared cache+    Improve cmd on async exceptions with nested processes on Windows 0.18.2, released 2019-05-19     #678, fix serious bug in writeFileChanged 0.18.1, released 2019-05-19

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.18.2+version:            0.18.3 license:            BSD3 license-file:       LICENSE category:           Development, Shake

@@ -335,8 +335,10 @@     ,opts $ Option ""  ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."     ,opts $ Option ""  ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."     ,opts $ Option ""  ["share"] (optArg "DIRECTORY" $ \x s -> s{shakeShare=Just $ fromMaybe "" x, shakeChange=ensureHash $ shakeChange s}) "Shared cache location."-    ,hide  $ Option ""  ["share-list"] (noArg ([ShareList], ensureShare)) "List the shared cache files."+    ,hide $ Option ""  ["share-list"] (noArg ([ShareList], ensureShare)) "List the shared cache files."     ,hide $ Option ""  ["share-remove"] (OptArg (\x -> Right ([ShareRemove $ fromMaybe "**" x], ensureShare)) "SUBSTRING") "Remove the shared cache keys."+    ,opts $ Option ""  ["share-copy"] (noArg $ \s -> s{shakeSymlink=False}) "Copy files into the cache."+    ,opts $ Option ""  ["share-symlink"] (noArg $ \s -> s{shakeSymlink=True}) "Symlink files into the cache."     ,opts $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."     ,extr $ Option ""  ["sleep"] (noArg [Sleep]) "Sleep for a second before building."     ,opts $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."

@@ -32,12 +32,13 @@ import qualified General.TypeMap as TMap import Data.Maybe import Data.IORef-import Data.Semigroup (Semigroup (..))+import Data.Semigroup import qualified Data.ByteString.Lazy as LBS import qualified Data.Binary.Builder as Bin import Data.Binary.Put import Data.Binary.Get import General.ListBuilder+import Prelude  #if __GLASGOW_HASKELL__ >= 800 import Control.Monad.Fail

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, PatternGuards #-}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE ConstraintKinds, TupleSections, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} @@ -370,7 +370,7 @@      shared <- case shakeShare opts of         Nothing -> return Nothing-        Just x -> Just <$> newShared wit2 ver x+        Just x -> Just <$> newShared (shakeSymlink opts) wit2 ver x     cloud <- case newCloud (runLocked var) (Map.map builtinKey owitness) ver keyVers $ shakeCloud opts of         _ | null $ shakeCloud opts -> return Nothing         Nothing -> fail "shakeCloud set but Shake not compiled for cloud operation"

@@ -34,10 +34,11 @@     {globalVersion :: !Ver     ,keyOp :: BinaryOp Key     ,sharedRoot :: FilePath+    ,useSymlink :: Bool     } -newShared :: BinaryOp Key -> Ver -> FilePath -> IO Shared-newShared keyOp globalVersion sharedRoot = return Shared{..}+newShared :: Bool -> BinaryOp Key -> Ver -> FilePath -> IO Shared+newShared useSymlink keyOp globalVersion sharedRoot = return Shared{..}   data Entry = Entry@@ -117,7 +118,7 @@                 let result x = if isJust x then Nothing else Just $ (entryResult, map (map fst) entryDepends, ) $ do                         let dir = sharedFileDir shared entryKey                         forM_ entryFiles $ \(file, hash) ->-                            copyFileLink (dir </> show hash) file+                            copyFileLink (useSymlink shared) (dir </> show hash) file                 result <$> firstJustM id                     [ firstJustWaitUnordered id                         [ test <$> ask k | (k, i1) <- kis@@ -134,7 +135,7 @@     BS.writeFile (dir </> "_key" </> hexed v) v     forM_ (entryFiles entry) $ \(file, hash) ->         unlessM (doesFileExist_ $ dir </> show hash) $-            copyFileLink file (dir </> show hash)+            copyFileLink (useSymlink shared) file (dir </> show hash)   addShared :: Shared -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()

@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}  module Development.Shake.Internal.History.Symlink(-    copyFileLink+    copyFileLink,+    createLinkMaybe     ) where  import Control.Monad.Extra@@ -17,7 +18,7 @@ import System.Posix.Files(createLink) #endif -createLinkBool :: FilePath -> FilePath -> IO (Maybe String)+createLinkMaybe :: FilePath -> FilePath -> IO (Maybe String)  #ifdef mingw32_HOST_OS @@ -29,25 +30,26 @@  foreign import CALLCONV unsafe "Windows.h CreateHardLinkW " c_CreateHardLinkW :: CWString -> CWString -> Ptr () -> IO Bool -createLinkBool from to = withCWString from $ \cfrom -> withCWString to $ \cto -> do+createLinkMaybe from to = withCWString from $ \cfrom -> withCWString to $ \cto -> do     res <- c_CreateHardLinkW cto cfrom nullPtr     return $ if res then Nothing else Just "CreateHardLink failed."  #else -createLinkBool from to = handleIO (return . Just . show) $ createLink from to >> return Nothing+createLinkMaybe from to = handleIO (return . Just . show) $ createLink from to >> return Nothing  #endif  -copyFileLink :: FilePath -> FilePath -> IO ()-copyFileLink from to = do+copyFileLink :: Bool -> FilePath -> FilePath -> IO ()+copyFileLink useSymlink from to = do     createDirectoryRecursive $ takeDirectory to     removeFile_ to-    b <- createLinkBool from to-    whenJust b $ \_ ->-        copyFile from to-    -- making files read only stops them from inadvertantly mutating the cache-    forM_ [from, to] $ \x -> do-        perm <- getPermissions x-        setPermissions x perm{writable=False}+    if not useSymlink then copyFile from to else do+        b <- createLinkMaybe from to+        whenJust b $ \_ ->+            copyFile from to+        -- making files read only stops them from inadvertantly mutating the cache+        forM_ [from, to] $ \x -> do+            perm <- getPermissions x+            setPermissions x perm{writable=False}

@@ -205,6 +205,8 @@         -- ^ Defaults to 'Nothing'. Whether to use and store outputs in a shared directory.     ,shakeCloud :: [String]         -- ^ Defaults to @[]@. Cloud servers to talk to forming a shared cache.+    ,shakeSymlink :: Bool+        -- ^ Defaults to @True@. Use symlinks if they are available.     ,shakeProgress :: IO Progress -> IO ()         -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported.         --   The function is called on a separate thread, and that thread is killed when the build completes.@@ -229,7 +231,7 @@ shakeOptions :: ShakeOptions shakeOptions = ShakeOptions     ".shake" 1 "1" Normal False [] Nothing [] [] [] [] (Just 10) [] [] False True False-    True ChangeModtime True [] False False Nothing []+    True ChangeModtime True [] False False Nothing [] True     (const $ return ())     (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS     (\_ _ _ -> return ())@@ -240,20 +242,20 @@     ,"shakeLint", "shakeLintInside", "shakeLintIgnore", "shakeLintWatch", "shakeCommandOptions"     ,"shakeFlush", "shakeRebuild", "shakeAbbreviations", "shakeStorageLog"     ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"-    ,"shakeLiveFiles", "shakeVersionIgnore", "shakeColor", "shakeShare", "shakeCloud"+    ,"shakeLiveFiles", "shakeVersionIgnore", "shakeColor", "shakeShare", "shakeCloud", "shakeSymlink"     ,"shakeProgress", "shakeOutput", "shakeTrace", "shakeExtra"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 y1 y2 y3 y4 =-    ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 y1 y2 y3 y4 =+    ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26         (fromHidden y1) (fromHidden y2) (fromHidden y3) (fromHidden y4)  instance Data ShakeOptions where-    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 y1 y2 y3 y4) =+    gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 y1 y2 y3 y4) =         z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k`-        x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` x25 `k`+        x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` x25 `k` x26 `k`         Hidden y1 `k` Hidden y2 `k` Hidden y3 `k` Hidden y4-    gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide+    gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide     toConstr ShakeOptions{} = conShakeOptions     dataTypeOf _ = tyShakeOptions 

@@ -4,7 +4,8 @@     Bilist, cons, snoc, uncons, toList, isEmpty     ) where -import Data.Semigroup (Semigroup(..))+import Data.Semigroup+import Prelude   data Bilist a = Bilist [a] [a]

@@ -22,7 +22,8 @@ import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.UTF8 as UTF8-import Data.Semigroup (Semigroup (..))+import Data.Semigroup+import Prelude   ---------------------------------------------------------------------

@@ -5,7 +5,9 @@     Tree(..), flattenTree, unflattenTree     ) where -import Data.Semigroup (Semigroup (..))+import Data.Semigroup+import Prelude+  -- ListBuilder is opaque outside this module newtype ListBuilder a = ListBuilder (Tree a)

@@ -6,7 +6,7 @@     process, ProcessOpts(..), Source(..), Destination(..)     ) where -import Control.Concurrent+import Control.Concurrent.Extra import Control.DeepSeq import Control.Exception.Extra as C import Control.Monad.Extra@@ -104,6 +104,17 @@     _ -> throwIO e  +withExceptions :: IO () -> IO a -> IO a+withExceptions stop go = do+    bar <- newBarrier+    v <- mask $ \unmask -> do+        forkFinally (unmask go) $ signalBarrier bar+        unmask (waitBarrier bar) `onException` do+            forkIO stop+            waitBarrier bar+    either throwIO return v++ withTimeout :: Maybe Double -> IO () -> IO a -> IO a withTimeout Nothing _ go = go withTimeout (Just s) stop go = bracket (forkIO $ sleep s >> stop) killThread $ const go@@ -125,7 +136,7 @@ abort :: ProcessHandle -> IO () abort pid = do     interruptProcessGroupOf pid-    sleep 5 -- give the process a few seconds grace period to die nicely+    sleep 3 -- give the process a few seconds grace period to die nicely     -- seems to happen with some GHC 7.2 compiled binaries with FFI etc     terminateProcess pid @@ -141,11 +152,11 @@     let outFiles = nubOrd [x | DestFile x <- poStdout ++ poStderr]     let inFiles = nubOrd [x | SrcFile x <- poStdin]     withFiles WriteMode outFiles $ \outHandle -> withFiles ReadMode inFiles $ \inHandle -> do-        let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = isJust poTimeout, close_fds = True+        let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = True, close_fds = True                  ,std_in = fst $ stdIn inHandle poStdin                  ,std_out = stdStream outHandle poStdout poStderr, std_err = stdStream outHandle poStderr poStdout}         withCreateProcessCompat cp $ \inh outh errh pid ->-            withTimeout poTimeout (abort pid) $ do+            withExceptions (abort pid) $ withTimeout poTimeout (abort pid) $ do                  let streams = [(outh, stdout, poStdout) | Just outh <- [outh], CreatePipe <- [std_out cp]] ++                               [(errh, stderr, poStderr) | Just errh <- [errh], CreatePipe <- [std_err cp]]

@@ -17,7 +17,7 @@ unF :: F f -> f a unF x = case x of F x -> unsafeCoerce x -newtype Map (f :: * -> *) = Map (Map.HashMap TypeRep (F f))+newtype Map f = Map (Map.HashMap TypeRep (F f))  empty :: Map f empty = Map Map.empty

@@ -28,6 +28,7 @@      let helper_source = unlines             ["import System.Time.Extra"+            ,"import System.Process"             ,"import Control.Monad"             ,"import System.Directory"             ,"import System.Environment"@@ -36,6 +37,7 @@             ,"import qualified Data.ByteString.Lazy.Char8 as LBS"             ,"main = do"             ,"    args <- getArgs"+            ,"    exe <- getExecutablePath"             ,"    forM_ args $ \\(a:rg) -> do"             ,"        case a of"             ,"            'o' -> putStrLn rg"@@ -46,6 +48,7 @@             ,"            'w' -> sleep (read rg :: Double)"             ,"            'r' -> LBS.putStr $ LBS.replicate (read rg) 'x'"             ,"            'i' -> putStr =<< getContents"+            ,"            's' -> void $ readProcess exe [rg] \"\""             ,"        hFlush stdout"             ,"        hFlush stderr"             ]@@ -95,7 +98,11 @@      "timeout2" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ helper "w20" +    -- commented out beause on Windows when you abort a Shell process you get a+    -- Do you want to terminate the batch file (Y/N)     when False $ "timeout3" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ Shell helper "w20"++    "timeout4" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ helper "sw20"      "env" !> do         -- use liftIO since it blows away PATH which makes lint-tracker stop working

@@ -35,7 +35,7 @@         path <- getEnv "GHC_PACKAGE_PATH"         liftIO $ createDirectoryRecursive "dist"         dist <- liftIO $ canonicalizePath "dist" -- make sure it works even if we cwd-        cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell Setup.hs configure"+        cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell -package=Cabal Setup.hs configure"             ["--builddir=" ++ dist,"--user"]             -- package-db is very sensitive, see #267             -- note that the reverse ensures the behaviour is consistent between the flags and the env variable@@ -51,7 +51,7 @@         needSource         trackIgnore         dist <- liftIO $ canonicalizePath "dist"-        cmd (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell Setup.hs haddock" ["--builddir=" ++ dist]+        cmd (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell -package=Cabal Setup.hs haddock" ["--builddir=" ++ dist]      "Part_*.hs" %> \out -> do         need [shakeRoot </> "src/Test/Docs.hs"] -- so much of the generator is in this module@@ -152,13 +152,13 @@             ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs,                 not $ any (`isSuffixOf` x) ["-Classes.html", "-FilePath.html"]] ++             ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd,-                takeBaseName x `notElem` ["Developing","Model"]]+                takeBaseName x `notElem` ["Developing","Model","Architecture"]]      let needModules = do mods <- readFileLines "Files.lst"; need [m <.> "hs" | m <- mods]; return mods      "Main.hs" %> \out -> do         mods <- needModules-        writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m | m <- mods] ++ ["main = return ()"]+        writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m ++ "()" | m <- mods] ++ ["main = return ()"]      "Success.txt" %> \out -> do         putNormal . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst"@@ -241,7 +241,7 @@ isBindStmt x = "let " `isPrefixOf` x || " <- " `isInfixOf` x  isDecl :: String -> Bool-isDecl x | fst (word1 x) `elem` ["import","infix","instance","newtype"] = True+isDecl x | fst (word1 x) `elem` ["import","infix","instance","newtype","data"] = True isDecl (words -> name:"::":_) | all isAlphaNum name = True -- foo :: Type Signature isDecl x | "=" `elem` takeWhile (`notElem` ["let","where"]) (words $ takeWhile (/= '{') x) = True -- foo arg1 arg2 = an implementation isDecl _ = False

@@ -2,11 +2,13 @@  module Test.History(main) where +import Control.Monad.Extra import Development.Shake import Test.Type import General.Extra import General.GetOpt import System.Directory+import Development.Shake.Internal.History.Symlink   data Args = Die deriving (Eq,Enum,Bounded,Show)@@ -24,6 +26,12 @@      "OutFile.txt" %> \out -> die $ copyFile' "In.txt" out +    "OutFile.link.txt" %> \out -> die $ do+        need ["In.txt"]+        whenJustM (liftIO $ createLinkMaybe "In.txt" out) $ \_ ->+            -- just is equivalent to an error happening, so just copy the file+            writeFile' out =<< readFile' "In.txt"+     reader <- addOracleCache $ \x -> die (readFile' x)     "OutOracle.txt" %> \out -> do         historyDisable@@ -33,30 +41,31 @@         copyFile' "In.txt" out1         copyFile' "In.txt" out2 -test build = do-    let setIn = writeFile "In.txt"-    let outs = ["OutFile.txt","OutOracle.txt","OutFiles1.txt","OutFiles2.txt","Phony.txt"]-    let checkOut x = mapM_ (`assertContents` x) outs+test build =+    forM_ [[],["--share-copy"]] $ \args -> do+        let setIn = writeFile "In.txt"+        let outs = ["OutFile.txt","OutOracle.txt","OutFiles1.txt","OutFiles2.txt","Phony.txt"] -- ,"OutFile.link.txt"]+        let checkOut x = mapM_ (`assertContents` x) outs -    build ["clean"]-    setIn "1"-    build $ ["--share","--sleep"] ++ outs-    checkOut "1"-    setIn "2"-    build $ ["--share","--sleep"] ++ outs-    checkOut "2"+        build ["clean"]+        setIn "1"+        build $ args ++ ["--share","--sleep"] ++ outs+        checkOut "1"+        setIn "2"+        build $ args ++ ["--share","--sleep"] ++ outs+        checkOut "2" -    setIn "1"-    assertException [] $ build ["OutFile.txt","--die","--quiet","--sleep"]-    build $ ["--die","--share"] ++ outs-    checkOut "1"+        setIn "1"+        assertException [] $ build ["OutFile.txt","--die","--quiet","--sleep"]+        build $ args ++ ["--die","--share"] ++ outs+        checkOut "1" -    setIn "2"-    mapM_ removeFile_ outs-    build $ ["--die","--share"] ++ outs-    checkOut "2"+        setIn "2"+        mapM_ removeFile_ outs+        build $ args ++ ["--die","--share"] ++ outs+        checkOut "2" -    setIn "2"-    removeFile ".shake.database"-    build $ ["--die","--share"] ++ outs-    checkOut "2"+        setIn "2"+        removeFile ".shake.database"+        build $ args ++ ["--die","--share"] ++ outs+        checkOut "2"

@@ -65,7 +65,7 @@         need $ hs : map (moduleToFile "hi") deps         ghc ["-c",hs,"-i" ++ shakeRoot </> "src","-main-is","Run.main"             ,"-hide-all-packages","-outputdir=."-            ,"-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch+            ,"-DPORTABLE"] -- to test one CPP branch      ".pkgs" %> \out -> do         src <- readFile' $ shakeRoot </> "shake.cabal"