├── tests ├── lint │ ├── dummy-file │ ├── accessed-before-need │ ├── accessed-without-need │ ├── .gitignore │ ├── lint.stderr │ └── Shakefile.hs ├── evan-hang │ ├── .gitignore │ ├── Util │ │ └── Regex.hs │ ├── App │ │ └── Main.hs │ └── Shakefile.hs ├── simple-hs │ ├── .gitignore │ ├── Utility.hs │ ├── Main.hs │ └── Shakefile.hs ├── lazy-exceptions │ ├── foo-dependency3 │ └── Shakefile.hs ├── simple-c │ ├── .gitignore │ ├── constants.h │ ├── main.c │ └── Shakefile.hs ├── ambiguous-rules │ ├── .gitignore │ └── Shakefile.hs ├── deserialization-changes │ ├── examplefile │ ├── MyOracle.inc │ ├── Shakefile-1.hs │ ├── Shakefile-2.hs │ └── Shakefile-3.hs ├── lexical-scope │ ├── .gitignore │ └── Shakefile.hs ├── creates-directory-implicitly │ ├── .gitignore │ └── Shakefile.hs ├── cyclic │ └── Shakefile.hs ├── cyclic-harder │ └── Shakefile.hs └── Test.lhs ├── Setup.lhs ├── .ghci ├── .gitignore ├── Development ├── Shake │ ├── Oracles.hs │ ├── C.hs │ ├── Core │ │ ├── Binary.hs │ │ ├── WaitHandle.hs │ │ └── Utilities.hs │ ├── Oracles │ │ ├── String.hs │ │ ├── FileSystem.hs │ │ └── Common.hs │ ├── System.hs │ ├── Composition.hs │ ├── Files.hs │ └── Core.hs └── Shake.hs ├── LICENSE └── openshake.cabal /tests/lint/dummy-file: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/evan-hang/.gitignore: -------------------------------------------------------------------------------- 1 | main -------------------------------------------------------------------------------- /tests/lint/accessed-before-need: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/lint/accessed-without-need: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/simple-hs/.gitignore: -------------------------------------------------------------------------------- 1 | Main -------------------------------------------------------------------------------- /tests/lazy-exceptions/foo-dependency3: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/simple-c/.gitignore: -------------------------------------------------------------------------------- 1 | Main 2 | -------------------------------------------------------------------------------- /tests/ambiguous-rules/.gitignore: -------------------------------------------------------------------------------- 1 | foo 2 | 3 | -------------------------------------------------------------------------------- /tests/deserialization-changes/examplefile: -------------------------------------------------------------------------------- 1 | OK3 -------------------------------------------------------------------------------- /tests/simple-c/constants.h: -------------------------------------------------------------------------------- 1 | #define MY_CONSTANT 43 -------------------------------------------------------------------------------- /tests/lexical-scope/.gitignore: -------------------------------------------------------------------------------- 1 | examplefile 2 | 3 | -------------------------------------------------------------------------------- /tests/creates-directory-implicitly/.gitignore: -------------------------------------------------------------------------------- 1 | subdirectory/ 2 | -------------------------------------------------------------------------------- /tests/simple-hs/Utility.hs: -------------------------------------------------------------------------------- 1 | module Utility where 2 | 3 | utility = 2 -------------------------------------------------------------------------------- /tests/lint/.gitignore: -------------------------------------------------------------------------------- 1 | access-before-need 2 | access-without-need 3 | need-without-access 4 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /tests/evan-hang/Util/Regex.hs: -------------------------------------------------------------------------------- 1 | module Util.Regex where 2 | 3 | regex_stuff = "I'm a regex module!" -------------------------------------------------------------------------------- /tests/simple-hs/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Utility 4 | 5 | main = print utility -------------------------------------------------------------------------------- /tests/evan-hang/App/Main.hs: -------------------------------------------------------------------------------- 1 | module App.Main where 2 | 3 | import Util.Regex 4 | 5 | main = print regex_stuff -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -Wall -fno-warn-name-shadowing 2 | -- :l "Development/Shake.hs" 3 | :l "tests/simple-c/Shakefile.hs" 4 | -------------------------------------------------------------------------------- /tests/simple-c/main.c: -------------------------------------------------------------------------------- 1 | #include "constants.h" 2 | #include 3 | 4 | int main(void) { 5 | printf("The magic number is %d\n", MY_CONSTANT); 6 | return 0; 7 | } 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # OS junk 2 | Thumbs.db 3 | .DS_Store 4 | 5 | # Shake generated files 6 | .openshake-db 7 | openshake-report.html 8 | 9 | # Build artifacts 10 | dist/ 11 | *.o 12 | *.hi 13 | -------------------------------------------------------------------------------- /tests/cyclic/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | 3 | 4 | main :: IO () 5 | main = shake $ do 6 | "a" *> \x -> do 7 | need ["b"] 8 | "b" *> \x -> do 9 | need ["a"] 10 | want ["a"] 11 | -------------------------------------------------------------------------------- /tests/lint/lint.stderr: -------------------------------------------------------------------------------- 1 | Database did not exist, doing full rebuild 2 | ./accessed-without-need was accessed without 'need'ing it first 3 | ./accessed-before-need was accessed without 'need'ing it first 4 | dummy-file was 'need'ed without ever being accessed 5 | -------------------------------------------------------------------------------- /tests/creates-directory-implicitly/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.System 3 | 4 | import System.FilePath 5 | 6 | 7 | main :: IO () 8 | main = shake $ do 9 | ("subdirectory" "foo") *> \x -> do 10 | system' $ ["touch",x] 11 | want ["subdirectory/foo"] 12 | -------------------------------------------------------------------------------- /Development/Shake/Oracles.hs: -------------------------------------------------------------------------------- 1 | module Development.Shake.Oracles ( 2 | module Development.Shake.Oracles.Common, 3 | module Development.Shake.Oracles.FileSystem, 4 | module Development.Shake.Oracles.String 5 | ) where 6 | 7 | import Development.Shake.Oracles.Common 8 | import Development.Shake.Oracles.FileSystem 9 | import Development.Shake.Oracles.String 10 | -------------------------------------------------------------------------------- /tests/ambiguous-rules/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.System 3 | 4 | import Control.Monad.IO.Class 5 | 6 | import System.FilePath 7 | 8 | 9 | main :: IO () 10 | main = shake $ do 11 | "foo" *> \x -> do 12 | liftIO $ writeFile x "First rule" 13 | "foo" *> \x -> do 14 | liftIO $ writeFile x "Second rule" 15 | want ["foo"] 16 | -------------------------------------------------------------------------------- /tests/cyclic-harder/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | 3 | 4 | main :: IO () 5 | main = shake $ do 6 | "a" *> \x -> do 7 | need ["b"] 8 | "b" *> \x -> do 9 | need ["a"] 10 | -- Because we "want" the two files simultaneously, they will each get 11 | -- built on a different thread. This causes the current (simpleminded) cycle 12 | -- detector to not detect a cycle. 13 | want ["a", "b"] 14 | -------------------------------------------------------------------------------- /tests/deserialization-changes/MyOracle.inc: -------------------------------------------------------------------------------- 1 | newtype MyOracle = MO { unMO :: Int } 2 | deriving (Typeable) 3 | 4 | instance Oracle MyOracle where 5 | newtype Question MyOracle = MOQ { unMOQ :: () } 6 | deriving (Eq, Ord, Show, NFData) 7 | newtype Answer MyOracle = MOA { unOA :: Int } 8 | deriving (Eq, Show, NFData) 9 | queryOracle (MO o) (MOQ ()) = return (MOA o) 10 | -------------------------------------------------------------------------------- /tests/simple-c/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.C 3 | import Development.Shake.System 4 | 5 | import System.FilePath 6 | 7 | 8 | main :: IO () 9 | main = shake $ do 10 | "Main" *> \x -> do 11 | cs <- ls "*.c" 12 | let os = map (`replaceExtension` "o") cs 13 | need os 14 | system' $ ["gcc","-o",x] ++ os 15 | "*.o" *> \x -> do 16 | let c = replaceExtension x "c" 17 | need =<< cppIncludes c 18 | system' ["gcc","-c",c,"-o",x] 19 | want ["Main"] 20 | -------------------------------------------------------------------------------- /tests/simple-hs/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.C 3 | import Development.Shake.System 4 | 5 | import System.FilePath 6 | 7 | import Control.Monad 8 | 9 | main :: IO () 10 | main = shake $ do 11 | "Main" *> \x -> do 12 | need ["Main.o", "Utility.o"] 13 | system' ["ghc", "-o", x, 14 | "Utility.o", "Main.o"] 15 | (\x -> guard (takeExtension x == ".o") >> return [x, replaceExtension x "hi"]) ?@> \o -> do 16 | let hs = replaceExtension o "hs" 17 | need $ [hs] ++ [y | hs == "Main.hs", y <- ["Utility.hi", "Utility.o"]] 18 | system' ["ghc", "-c", hs] 19 | want ["Main"] 20 | -------------------------------------------------------------------------------- /tests/lexical-scope/Shakefile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | import Development.Shake 3 | import qualified Development.Shake.Core as Core 4 | import Development.Shake.Oracles.String 5 | 6 | import Control.Monad.IO.Class 7 | 8 | 9 | main :: IO () 10 | main = (Core.shake :: Shake (Question StringOracle :+: CanonicalFilePath) () -> IO ()) $ do 11 | installOracle (StringOracle (const $ return ["foo"])) `privateTo_` do 12 | "examplefile" *> \x -> do 13 | ["foo"] <- queryStringOracle ("silly", "question") 14 | liftIO $ writeFile "examplefile" "Dummy contents" 15 | 16 | installOracle (StringOracle (const $ return ["bar"])) `privateTo_` want ["examplefile"] 17 | -------------------------------------------------------------------------------- /tests/lazy-exceptions/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.System 3 | 4 | import System.FilePath 5 | 6 | import Control.Exception 7 | import Control.Monad.IO.Class 8 | 9 | 10 | main :: IO () 11 | main = shake $ do 12 | "foo-dependency1" *> \x -> do 13 | need ["impossible-file"] 14 | 15 | "foo-dependency2" *> \x -> do 16 | liftIO $ throwIO $ ErrorCall "User error in foo-dependency2 rule" 17 | 18 | "foo-dependency3" *> \x -> do 19 | system' ["touch", "foo-dependency3"] 20 | 21 | "foo" *> \x -> do 22 | need ["foo-dependency1", "foo-dependency2", "foo-dependency3"] 23 | need ["unreachable-need"] 24 | 25 | "bar" *> \x -> do 26 | liftIO $ throwIO $ ErrorCall "User error in bar rule" 27 | 28 | want ["foo", "bar"] 29 | -------------------------------------------------------------------------------- /tests/lint/Shakefile.hs: -------------------------------------------------------------------------------- 1 | import Development.Shake 2 | import Development.Shake.System 3 | 4 | import System.FilePath 5 | 6 | import Control.Exception 7 | import Control.Monad.IO.Class 8 | 9 | 10 | main :: IO () 11 | main = shake $ do 12 | "access-without-need" *> \x -> do 13 | liftIO $ readFile "accessed-without-need" >>= putStrLn -- It's very important we actually use the contents of the file, or it doesn't count as an access! 14 | system' ["touch", "access-without-need"] 15 | 16 | "access-before-need" *> \x -> do 17 | liftIO $ readFile "accessed-before-need" >>= putStrLn -- Ditto 18 | need ["accessed-before-need"] 19 | system' ["touch", "access-before-need"] 20 | 21 | "need-without-access" *> \x -> do 22 | need ["dummy-file"] 23 | system' ["touch", "need-without-access"] 24 | 25 | want ["access-without-need", "access-before-need", "need-without-access"] 26 | -------------------------------------------------------------------------------- /tests/deserialization-changes/Shakefile-1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, CPP, TypeFamilies, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, TypeOperators #-} 2 | import Development.Shake 3 | import qualified Development.Shake.Core as Core 4 | 5 | import Control.DeepSeq 6 | import Control.Monad.IO.Class 7 | import Data.Binary 8 | import Data.Typeable 9 | 10 | 11 | #include "MyOracle.inc" 12 | 13 | 14 | instance Binary (Question MyOracle) where 15 | get = return (MOQ ()) 16 | put (MOQ ()) = return () 17 | 18 | instance Binary (Answer MyOracle) where 19 | get = fmap MOA get 20 | put (MOA i) = put i 21 | 22 | 23 | main :: IO () 24 | main = (Core.shake :: Shake (Question MyOracle :+: CanonicalFilePath) () -> IO ()) $ do 25 | installOracle (MO 1) 26 | 27 | "examplefile" *> \x -> do 28 | MOA 1 <- query $ MOQ () 29 | liftIO $ writeFile "examplefile" "OK1" 30 | 31 | want ["examplefile"] 32 | -------------------------------------------------------------------------------- /Development/Shake/C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, TypeOperators #-} 2 | module Development.Shake.C( 3 | cppIncludes 4 | ) where 5 | 6 | import Development.Shake 7 | import Development.Shake.System 8 | 9 | import Control.Monad 10 | 11 | import Data.Char 12 | import Data.List 13 | import Data.Maybe 14 | 15 | import System.FilePath 16 | 17 | cppIncludes :: (CanonicalFilePath :< n, Namespace n) 18 | => FilePath -> Act n [FilePath] 19 | cppIncludes fp = fmap (map (takeDirectory fp ) . mapMaybe takeInclude) $ readFileLines fp 20 | where 21 | -- TODO: should probably do better than this quick and dirty hack 22 | -- FIXME: transitive dependencies 23 | trim p = dropWhile p . reverse . dropWhile p . reverse 24 | takeInclude xs = guard ("#include" `isPrefixOf` map toLower xs) >> stripQuotes (trim isSpace (drop (length "#include") xs)) 25 | stripQuotes ('\"':xs) = guard (not (null xs) && last xs == '\"') >> return (init xs) 26 | stripQuotes _ = Nothing 27 | -------------------------------------------------------------------------------- /Development/Shake/Core/Binary.hs: -------------------------------------------------------------------------------- 1 | module Development.Shake.Core.Binary where 2 | 3 | import Development.Shake.Core.Utilities 4 | 5 | import Data.Binary 6 | import Data.Binary.Get 7 | import Data.Binary.Put 8 | 9 | import qualified Data.ByteString.Lazy as BS 10 | import qualified Codec.Binary.UTF8.String as UTF8 11 | 12 | 13 | getSizedByteString :: Get BS.ByteString 14 | getSizedByteString = do 15 | n <- getWord32le 16 | getLazyByteString (fromIntegral n) 17 | 18 | putSizedByteString :: BS.ByteString -> Put 19 | putSizedByteString bs = do 20 | putWord32le (fromIntegral (BS.length bs)) 21 | putLazyByteString bs 22 | 23 | getList :: Get a -> Get [a] 24 | getList get_elt = do 25 | n <- getWord32le 26 | genericReplicateM n get_elt 27 | 28 | putList :: (a -> Put) -> [a] -> Put 29 | putList put_elt xs = do 30 | putWord32le (fromIntegral (length xs)) 31 | mapM_ put_elt xs 32 | 33 | getUTF8String :: Get String 34 | getUTF8String = fmap UTF8.decode $ getList getWord8 35 | 36 | putUTF8String :: String -> Put 37 | putUTF8String = putList putWord8 . UTF8.encode 38 | -------------------------------------------------------------------------------- /tests/deserialization-changes/Shakefile-2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, CPP, TypeFamilies, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, TypeOperators #-} 2 | import Development.Shake 3 | import qualified Development.Shake.Core as Core 4 | 5 | import Control.DeepSeq 6 | import Control.Monad.IO.Class 7 | import Data.Binary 8 | import Data.Binary.Get 9 | import Data.Binary.Put 10 | import Data.Typeable 11 | 12 | 13 | #include "MyOracle.inc" 14 | 15 | 16 | instance Binary (Question MyOracle) where 17 | get = return (MOQ ()) 18 | put (MOQ ()) = return () 19 | 20 | -- Make the answer shorter (tests that we check that all input is consumed by the deserializer) 21 | instance Binary (Answer MyOracle) where 22 | get = fmap (MOA . fromIntegral) getWord16le 23 | put (MOA i) = putWord16le (fromIntegral i) 24 | 25 | 26 | main :: IO () 27 | main = (Core.shake :: Shake (Question MyOracle :+: CanonicalFilePath) () -> IO ()) $ do 28 | installOracle (MO 1) 29 | 30 | "examplefile" *> \x -> do 31 | MOA 1 <- query $ MOQ () 32 | liftIO $ writeFile "examplefile" "OK2" 33 | 34 | want ["examplefile"] 35 | -------------------------------------------------------------------------------- /tests/deserialization-changes/Shakefile-3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, CPP, TypeFamilies, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, TypeOperators #-} 2 | import Development.Shake 3 | import qualified Development.Shake.Core as Core 4 | 5 | import Control.DeepSeq 6 | import Control.Monad.IO.Class 7 | import Data.Binary 8 | import Data.Binary.Get 9 | import Data.Binary.Put 10 | import Data.Typeable 11 | 12 | 13 | #include "MyOracle.inc" 14 | 15 | 16 | -- Make the question longer (tests that we check that question deserialization is tested) 17 | instance Binary (Question MyOracle) where 18 | get = do { 0 <- getWord8; return (MOQ ()) } 19 | put (MOQ ()) = putWord8 0 20 | 21 | instance Binary (Answer MyOracle) where 22 | get = fmap (MOA . fromIntegral) getWord16le 23 | put (MOA i) = putWord16le (fromIntegral i) 24 | 25 | 26 | main :: IO () 27 | main = (Core.shake :: Shake (Question MyOracle :+: CanonicalFilePath) () -> IO ()) $ do 28 | installOracle (MO 1) 29 | 30 | "examplefile" *> \x -> do 31 | MOA 1 <- query $ MOQ () 32 | liftIO $ writeFile "examplefile" "OK3" 33 | 34 | want ["examplefile"] 35 | -------------------------------------------------------------------------------- /Development/Shake/Core/WaitHandle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-} 2 | module Development.Shake.Core.WaitHandle ( 3 | WaitHandle, newWaitHandle, waitOnWaitHandle, mayWaitOnWaitHandle 4 | ) where 5 | 6 | import Control.Concurrent.MVar 7 | 8 | import Unsafe.Coerce (unsafeCoerce) 9 | 10 | 11 | -- | A 'WaitHandle' is basically just an 'MVar' that can only be put into once, and 12 | -- then never gets anything removed from it 13 | data WaitHandle a = forall b. WH (b -> a) (MVar b) 14 | 15 | instance Eq (WaitHandle a) where 16 | WH _ mvar1 == WH _ mvar2 = mvar1 == unsafeCoerce mvar2 17 | 18 | instance Show (WaitHandle a) where 19 | show (WH _ _) = "WaitHandle" 20 | 21 | instance Functor WaitHandle where 22 | fmap f (WH g mvar) = WH (f . g) mvar 23 | 24 | newWaitHandle :: IO (WaitHandle a, a -> IO ()) 25 | newWaitHandle = fmap (\mvar -> (WH id mvar, \x -> tryPutMVar mvar x >> return ())) newEmptyMVar 26 | 27 | waitOnWaitHandle :: WaitHandle a -> IO a 28 | waitOnWaitHandle (WH f mvar) = fmap f $ readMVar mvar 29 | 30 | -- | Looks ahead to see if the caller is likely to have to wait on the wait handle. 31 | -- If this function returns 'True' then they may or may not actually have to wait, 32 | -- but if the function returns 'False' then they certainly won't have to wait. 33 | mayWaitOnWaitHandle :: WaitHandle a -> IO Bool 34 | mayWaitOnWaitHandle (WH _ mvar) = isEmptyMVar mvar 35 | -------------------------------------------------------------------------------- /Development/Shake/Oracles/String.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} 2 | module Development.Shake.Oracles.String ( 3 | -- * Oracle type 4 | StringOracle(..), 5 | 6 | -- * Oracle operations 7 | queryStringOracle 8 | ) where 9 | 10 | import Development.Shake.Core 11 | import Development.Shake.Core.Binary 12 | import Development.Shake.Composition 13 | import Development.Shake.Oracles.Common 14 | 15 | import Data.Binary 16 | 17 | import Control.DeepSeq 18 | 19 | import Control.Monad 20 | 21 | 22 | newtype StringOracle = StringOracle ((String, String) -> IO [String]) 23 | 24 | instance Oracle StringOracle where 25 | newtype Question StringOracle = SQ { unSQ :: (String, String) } 26 | deriving (Eq, Ord, Show, NFData) 27 | newtype Answer StringOracle = SA { unSA :: [String] } 28 | deriving (Eq, Show, NFData) 29 | queryOracle (StringOracle f) = fmap SA . f . unSQ 30 | 31 | instance Binary (Question StringOracle) where 32 | get = fmap SQ $ liftM2 (,) getUTF8String getUTF8String 33 | put (SQ (x, y)) = putUTF8String x >> putUTF8String y 34 | 35 | instance Binary (Answer StringOracle) where 36 | get = fmap SA $ getList getUTF8String 37 | put = putList putUTF8String . unSA 38 | 39 | 40 | queryStringOracle :: (Question StringOracle :< ntop, Namespace ntop) => (String, String) -> Act ntop [String] 41 | queryStringOracle = fmap unSA . query . SQ 42 | -------------------------------------------------------------------------------- /Development/Shake/Oracles/FileSystem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} 2 | module Development.Shake.Oracles.FileSystem ( 3 | -- * Oracle type 4 | FileSystemOracle, 5 | 6 | -- * Oracle operations 7 | ls 8 | ) where 9 | 10 | import Development.Shake.Core 11 | import Development.Shake.Core.Binary 12 | import Development.Shake.Composition 13 | import Development.Shake.Oracles.Common 14 | 15 | import Data.Binary 16 | 17 | import Control.DeepSeq 18 | 19 | import System.Directory 20 | import System.FilePath.Glob 21 | 22 | 23 | data FileSystemOracle = FSO 24 | 25 | instance Oracle FileSystemOracle where 26 | newtype Question FileSystemOracle = Ls String 27 | deriving (Eq, Ord, Show, NFData) 28 | newtype Answer FileSystemOracle = LsAnswer [FilePath] 29 | deriving (Eq, Show, NFData) 30 | 31 | queryOracle FSO (Ls pattern) = fmap LsAnswer $ getCurrentDirectory >>= globDir1 (compile pattern) 32 | 33 | defaultOracle = Just FSO 34 | 35 | 36 | instance Binary (Question FileSystemOracle) where 37 | get = fmap Ls getUTF8String 38 | put (Ls x) = putUTF8String x 39 | 40 | instance Binary (Answer FileSystemOracle) where 41 | get = fmap LsAnswer $ getList getUTF8String 42 | put (LsAnswer xs) = putList putUTF8String xs 43 | 44 | 45 | ls :: (Question FileSystemOracle :< ntop, Namespace ntop) => String -> Act ntop [FilePath] 46 | ls pattern = fmap (\(LsAnswer fps) -> fps) $ query (Ls pattern) 47 | 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Development/Shake.hs: -------------------------------------------------------------------------------- 1 | -- | Top-level module that exports a commonly-used subset of the Shake API 2 | {-# LANGUAGE TypeOperators #-} 3 | module Development.Shake ( 4 | -- * The top-level monadic interface 5 | Shake, shake, 6 | 7 | -- * Adding file rules in the Shake monad and controlling their visibility 8 | Rule, CreatesFiles, (*>), (*@>), (**>), (**@>), (?>), (?@>), 9 | addRule, privateTo, privateTo_, 10 | 11 | -- * Demanding files and other things in the Shake monad 12 | want, act, 13 | 14 | -- * The monadic interface used by rule bodies 15 | Act, need, query, 16 | 17 | -- * Oracle definition 18 | Oracle(..), installOracle, 19 | 20 | -- * The file system oracle, and wrappers for the questions it can answer 21 | FileSystemOracle, ls, 22 | 23 | -- * Namespaces and namespace composition 24 | Namespace(..), (:+:), (:<), 25 | 26 | -- * The file namespace 27 | CanonicalFilePath, -- TODO: as an alternative, I could newtype the Shake/Act monads? 28 | 29 | -- * Verbosity and command-line output from Shake 30 | Verbosity(..), actVerbosity, putStrLnAt, 31 | 32 | -- * Adding to the Shake report 33 | reportCommand 34 | ) where 35 | 36 | import Development.Shake.Core hiding (Rule, shake, addRule, need) 37 | import qualified Development.Shake.Core as Core 38 | 39 | import Development.Shake.Composition hiding (need) 40 | import Development.Shake.Files 41 | import Development.Shake.Oracles 42 | 43 | 44 | shake :: Shake (Question FileSystemOracle :+: CanonicalFilePath) () -> IO () -- TODO: make ntop polymorphic 45 | shake act = Core.shake act 46 | -------------------------------------------------------------------------------- /tests/evan-hang/Shakefile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | import Development.Shake 3 | import Development.Shake.C 4 | import Development.Shake.System 5 | 6 | import qualified System.FilePath as FilePath 7 | 8 | import qualified Control.Monad.IO.Class as Trans 9 | import qualified Data.Map as Map 10 | import qualified Data.List as List 11 | 12 | main :: IO () 13 | main = shake $ do 14 | "main" *> \fn -> do 15 | need ["App/Main.o", "Util/Regex.o"] 16 | system' ["ghc", "-o", fn, "-main-is", "App.Main", 17 | "Util/Regex.o", "App/Main.o"] 18 | hs_rule 19 | want ["main"] 20 | 21 | hs_rule :: (CanonicalFilePath :< ntop, Namespace ntop) => Shake ntop () 22 | hs_rule = match ?@> \fn -> do 23 | let deps = Map.findWithDefault [] fn hs_deps 24 | need deps 25 | Trans.liftIO $ putStrLn $ "********* fn: " ++ show (fn, deps) 26 | compile_hs fn 27 | where 28 | match fn 29 | | ".o" `List.isSuffixOf` fn = 30 | Just [fn, FilePath.replaceExtension fn "hi"] 31 | -- The above two lines should be corrected as below, but Evan Laforge 32 | -- found that using the definition aboved caused a hang, which I'm testing here. 33 | -- | FilePath.takeExtension fn `elem` [".o", ".hi"] = 34 | -- Just [FilePath.replaceExtension fn "o", FilePath.replaceExtension fn "hi"] 35 | 36 | | otherwise = Nothing 37 | 38 | compile_hs :: (CanonicalFilePath :< ntop, Namespace ntop) => 39 | FilePath -> Act ntop () 40 | compile_hs fn = do 41 | need [hs_of fn] 42 | system' ["ghc", "-c", "-main-is", "App.Main", hs_of fn] 43 | 44 | hs_of :: FilePath -> FilePath 45 | hs_of fn = FilePath.replaceExtension fn "hs" 46 | 47 | hs_deps :: Map.Map FilePath [FilePath] 48 | hs_deps = Map.fromList 49 | [ ("App/Main.o", ["Util/Regex.hi"]) 50 | ] 51 | -------------------------------------------------------------------------------- /Development/Shake/Oracles/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} 2 | module Development.Shake.Oracles.Common ( 3 | -- * Defining oracles 4 | Oracle(..), 5 | 6 | -- * Installing oracles 7 | installOracle 8 | ) where 9 | 10 | import Development.Shake.Core 11 | import Development.Shake.Composition 12 | 13 | import Data.Binary 14 | 15 | import Control.DeepSeq 16 | 17 | import Control.Monad.IO.Class 18 | 19 | 20 | class (Ord (Question o), Eq (Answer o), 21 | Show (Question o), Show (Answer o), 22 | Binary (Question o), Binary (Answer o), 23 | NFData (Question o), NFData (Answer o)) => Oracle o where 24 | data Question o 25 | data Answer o 26 | 27 | queryOracle :: o -> Question o -> IO (Answer o) 28 | 29 | -- | The oracle that will be used if no other oracle of the right type gets explicitly installed 30 | defaultOracle :: Maybe o 31 | defaultOracle = Nothing 32 | 33 | instance Oracle o => Namespace (Question o) where 34 | type Entry (Question o) = Answer o 35 | 36 | -- We always fail an oracle sanity check> If we don't, oracles won't be rerun if their "dependencies" 37 | -- are unchanged, so if e.g. the contents of a directory is unchanged then ls won't be rerun to 38 | -- find the new answer. 39 | sanityCheck _ _ = return (Just "Oracle queries must always be rechecked") 40 | 41 | defaultRule q = case defaultOracle of 42 | Nothing -> return Nothing 43 | Just o -> liftIO $ oracleRule o q 44 | 45 | data Snapshot (Question o) = OracleSnapshot -- Nothing to sanity check: how could we tell if user code had used the result of a query? 46 | 47 | takeSnapshot = return OracleSnapshot 48 | lintSnapshots _ _ = [] 49 | 50 | 51 | oracleRule :: Oracle o => o -> Question o -> IO (Maybe ([Question o], Act ntop [Answer o])) 52 | oracleRule o q = return $ Just ([q], fmap return $ liftIO $ queryOracle o q) 53 | 54 | installOracle :: (Oracle o, Question o :< ntop) => o -> Shake ntop () 55 | installOracle o = addRule . liftRule $ oracleRule o 56 | -------------------------------------------------------------------------------- /openshake.cabal: -------------------------------------------------------------------------------- 1 | Name: openshake 2 | Version: 0.1 3 | Cabal-Version: >= 1.2 4 | Category: Distribution 5 | Synopsis: Powerful and easy to use build system: open source implementation of Neil Mitchell's Shake system 6 | Description: A library for constructing build systems, using Haskell as a powerful domain specific language 7 | for specifying rules. 8 | 9 | The best reference for how it works at the moment is Neil's presentation to the Haskell Implementors 10 | Workshop 2010 at 11 | License: BSD3 12 | License-File: LICENSE 13 | Author: Max Bolingbroke 14 | Maintainer: Max Bolingbroke 15 | Homepage: http://www.github.com/batterseapower/openshake 16 | Build-Type: Simple 17 | 18 | Library 19 | Exposed-Modules: Development.Shake 20 | Development.Shake.C 21 | Development.Shake.Composition 22 | Development.Shake.Core.Binary 23 | Development.Shake.Core.Utilities 24 | Development.Shake.Core.WaitHandle 25 | Development.Shake.Core 26 | Development.Shake.Files 27 | Development.Shake.Oracles.Common 28 | Development.Shake.Oracles.FileSystem 29 | Development.Shake.Oracles.String 30 | Development.Shake.Oracles 31 | Development.Shake.System 32 | 33 | Build-Depends: base >= 3 && < 5, containers >= 0.3, directory >= 1.0.1.1, 34 | filepath >= 1.1, old-time >= 1.0, time >= 1.4, process >= 1.0.1, 35 | Glob >= 0.5.1, transformers >= 0.2.2, 36 | bytestring >= 0.9.1, binary >= 0.5, utf8-string >= 0.3.6, 37 | parallel-io >= 0.2.1.1, temporary >= 1.1, 38 | deepseq >= 1.1, monad-peel >= 0.1, access-time >= 0.1, 39 | split >= 0.1.1 40 | 41 | if os(windows) 42 | Cpp-Options: -DWINDOWS 43 | -------------------------------------------------------------------------------- /Development/Shake/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, TypeOperators #-} 2 | module Development.Shake.System ( 3 | system, system', systemStdout', 4 | copy, mkdir, readFileLines, 5 | quote 6 | ) where 7 | 8 | import Development.Shake 9 | import qualified Development.Shake.Core.Utilities as Utilities 10 | 11 | import Control.Monad.IO.Class 12 | 13 | import Data.List 14 | 15 | import qualified System.Process as Process 16 | import System.Exit 17 | 18 | import System.Directory 19 | import System.FilePath 20 | 21 | 22 | system' :: [String] -> Act n () 23 | system' prog = do 24 | ec <- system prog 25 | Utilities.checkExitCode prog ec 26 | 27 | system :: [String] -> Act n ExitCode 28 | system prog = do 29 | putStrLnAt VerboseVerbosity cmd 30 | reportCommand cmd $ Process.system cmd 31 | where cmd = intercalate " " prog 32 | 33 | systemStdout' :: [String] -> Act n String 34 | systemStdout' prog = do 35 | (ec, stdout) <- systemStdout prog 36 | Utilities.checkExitCode prog ec 37 | return stdout 38 | 39 | systemStdout :: [String] -> Act n (ExitCode, String) 40 | systemStdout prog = do 41 | putStrLnAt VerboseVerbosity cmd 42 | reportCommand cmd $ Utilities.systemStdout cmd 43 | where cmd = intercalate " " prog 44 | 45 | control_characters :: [Char] 46 | control_characters = ['$', '`'] 47 | --meta_characters :: [Char] 48 | --meta_characters = [' ', '\t', '|', '&', ';', '(', ')', '<', '>'] 49 | 50 | -- | Shell escaping by double-quoting the argument. 51 | -- 52 | -- See 3.1.2.3 of 53 | quote :: String -> String 54 | quote x = "\"" ++ concatMap escape x ++ "\"" 55 | where must_escape = control_characters ++ ['\"', '\\'] 56 | escape c | c `elem` must_escape = ['\\', c] 57 | | otherwise = [c] 58 | 59 | -- TODO: I'm not using this at the moment 60 | -- 61 | -- -- | Shell escaping by backslash-encoding the argument. 62 | -- -- 63 | -- -- See 3.1.2.1 of 64 | -- escape :: String -> String 65 | -- escape x = concatMap escape x 66 | -- where must_escape = control_characters ++ meta_characters ++ ['\\', '\'', '\"'] 67 | -- escape c | c `elem` must_escape = ['\\', c] 68 | -- | otherwise = [c] 69 | 70 | readFileLines :: (CanonicalFilePath :< n, Namespace n) 71 | => FilePath -> Act n [String] 72 | readFileLines x = do 73 | need [x] 74 | liftIO $ fmap lines $ readFile x 75 | 76 | copy :: (CanonicalFilePath :< n, Namespace n) 77 | => FilePath -> FilePath -> Act n () 78 | copy from to = do 79 | mkdir $ takeDirectory to 80 | need [from] 81 | system' ["cp", quote from, quote to] 82 | 83 | mkdir :: FilePath -> Act n () 84 | mkdir fp = liftIO $ createDirectoryIfMissing True fp 85 | -------------------------------------------------------------------------------- /Development/Shake/Core/Utilities.hs: -------------------------------------------------------------------------------- 1 | module Development.Shake.Core.Utilities where 2 | 3 | import qualified Control.Exception as Exception 4 | 5 | import Control.Arrow (second) 6 | import Control.Monad 7 | 8 | import Data.List 9 | import Data.Maybe 10 | 11 | import System.Exit 12 | import qualified System.Process as Process 13 | 14 | import System.FilePath 15 | import System.IO.Error (isDoesNotExistError) 16 | import System.IO.Temp 17 | 18 | 19 | uncurry3 :: (a -> b -> c -> d) 20 | -> (a, b, c) -> d 21 | uncurry3 f (a, b, c) = f a b c 22 | 23 | snocView :: [a] -> Maybe ([a], a) 24 | snocView [] = Nothing 25 | snocView ss = Just (init ss, last ss) 26 | 27 | showStringList :: [String] -> String 28 | showStringList ss = case snocView ss of 29 | Nothing -> "" 30 | Just ([], s) -> s 31 | Just (ss', s) -> intercalate ", " ss' ++ " and " ++ s 32 | 33 | handleDoesNotExist :: IO a -> IO a -> IO a 34 | handleDoesNotExist = handleIf isDoesNotExistError 35 | 36 | handleIf :: Exception.Exception e => (e -> Bool) -> IO a -> IO a -> IO a 37 | handleIf p handler act = Exception.handleJust (guard . p) (\() -> handler) act 38 | 39 | fromRight :: (a -> b) -> Either a b -> b 40 | fromRight f (Left a) = f a 41 | fromRight _ (Right b) = b 42 | 43 | fmapEither :: (a -> b) -> (c -> d) -> Either a c -> Either b d 44 | fmapEither f _ (Left x) = Left (f x) 45 | fmapEither _ g (Right y) = Right (g y) 46 | 47 | expectJust :: String -> Maybe a -> a 48 | expectJust _ (Just x) = x 49 | expectJust msg Nothing = error $ "expectJust: " ++ msg 50 | 51 | lookupRemove :: Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)]) 52 | lookupRemove _ [] = Nothing 53 | lookupRemove want_k ((k, v):kvs) | want_k == k = Just (v, kvs) 54 | | otherwise = fmap (second ((k, v) :)) $ lookupRemove want_k kvs 55 | 56 | lookupRemoveMany :: Eq k => [k] -> [(k, v)] -> Either k ([(k, v)], [v]) 57 | lookupRemoveMany ks init_kvs 58 | = mapAccumLM (\kvs k -> case lookupRemove k kvs of Nothing -> Left k 59 | Just (v, kvs') -> Right (kvs', v)) init_kvs ks 60 | 61 | lookupMany :: Eq k => [k] -> [(k, v)] -> Either k [v] 62 | lookupMany ks = fmap snd . lookupRemoveMany ks 63 | 64 | fixEq :: Eq a => (a -> a) -> a -> a 65 | fixEq f x | x == x' = x 66 | | otherwise = fixEq f x' 67 | where x' = f x 68 | 69 | anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool 70 | anyM p = go 71 | where go [] = return False 72 | go (x:xs) = do 73 | b <- p x 74 | if b then return True 75 | else go xs 76 | 77 | firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) 78 | firstJustM = go 79 | where go [] = return Nothing 80 | go (mmb_x:xs) = do 81 | mb_x <- mmb_x 82 | maybe (go xs) (return . Just) mb_x 83 | 84 | firstJust :: [Maybe a] -> Maybe a 85 | firstJust = listToMaybe . catMaybes 86 | 87 | replicateM :: Monad m => Int -> m b -> m [b] 88 | replicateM = genericReplicateM 89 | 90 | genericReplicateM :: (Integral a, Monad m) => a -> m b -> m [b] 91 | genericReplicateM init_n act = go init_n [] 92 | where 93 | go 0 accum = return (reverse accum) 94 | go n accum = act >>= \x -> go (n - 1) (x:accum) 95 | 96 | mapAccumLM :: Monad m => (acc -> a -> m (acc, b)) -> acc -> [a] -> m (acc, [b]) 97 | mapAccumLM f = go [] 98 | where go ys acc [] = return (acc, reverse ys) 99 | go ys acc (x:xs) = do 100 | (acc', y) <- f acc x 101 | go (y:ys) acc' xs 102 | 103 | mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] 104 | mapMaybeM f = go 105 | where go [] = return [] 106 | go (x:xs) = do 107 | mb_y <- f x 108 | case mb_y of 109 | Nothing -> go xs 110 | Just y -> liftM (y:) (go xs) 111 | 112 | tap_ :: Monad m => m a -> m () -> m a 113 | tap_ mx mtap = tap mx (const mtap) 114 | 115 | tap :: Monad m => m a -> (a -> m ()) -> m a 116 | tap mx mtap = mx >>= \x -> mtap x >> return x 117 | 118 | listExtractors :: [[a] -> a] 119 | listExtractors = head : map (. tail) listExtractors 120 | 121 | (?) :: Bool -> (a, a) -> a 122 | True ? (t, _) = t 123 | False ? (_, f) = f 124 | 125 | swap :: (a, b) -> (b, a) 126 | swap (x, y) = (y, x) 127 | 128 | 129 | checkExitCode :: (Show a, Monad m) => a -> ExitCode -> m () 130 | checkExitCode cmd ec = case ec of 131 | ExitSuccess -> return () 132 | ExitFailure i -> error $ "system': system command " ++ show cmd ++ " failed with exit code " ++ show i 133 | 134 | systemStdout :: String -> IO (ExitCode, String) 135 | systemStdout cmd = withSystemTempDirectory "openshake" $ \tmpdir -> do 136 | let stdout_fp = tmpdir "stdout" <.> "txt" 137 | ec <- Process.system $ cmd ++ " > " ++ stdout_fp 138 | fmap ((,) ec) $ readFile stdout_fp 139 | 140 | systemStdout' :: String -> IO String 141 | systemStdout' cmd = do 142 | (ec, stdout) <- systemStdout cmd 143 | checkExitCode cmd ec 144 | return stdout 145 | -------------------------------------------------------------------------------- /Development/Shake/Composition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeFamilies, EmptyDataDecls #-} 2 | {-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, OverlappingInstances #-} -- For the (:<) subtyping relation 3 | module Development.Shake.Composition ( 4 | -- * Composing namespaces 5 | (:+:), Empty, 6 | 7 | -- * Subtyping 8 | (:<), liftRule, 9 | 10 | -- * Requesting that entries get built 11 | need, query 12 | ) where 13 | 14 | import Development.Shake.Core hiding (need) 15 | import qualified Development.Shake.Core as Core 16 | 17 | import Data.Binary 18 | 19 | import Control.DeepSeq 20 | 21 | import Control.Monad 22 | 23 | 24 | -- | Union together two namespaces. 25 | -- 26 | -- Trees of (:+:) must be right-biased, or the subtyping machinery won't be able to infer 27 | -- the subtype relationship. 28 | data (:+:) n1 n2 = LeftName n1 | RightName n2 29 | 30 | infixr 1 :+: -- Ensure right-biased construction by default 31 | 32 | fromLeftName :: n1 :+: n2 -> Maybe n1 33 | fromLeftName = \n -> case n of RightName _ -> Nothing; LeftName n1 -> Just n1 34 | 35 | fromRightName :: n1 :+: n2 -> Maybe n2 36 | fromRightName = \n -> case n of LeftName _ -> Nothing; RightName n2 -> Just n2 37 | 38 | instance (Namespace n1, Namespace n2) => Show (n1 :+: n2) where 39 | show (LeftName n1) = show n1 40 | show (RightName n2) = show n2 41 | 42 | deriving instance (Namespace n1, Namespace n2) => Eq (n1 :+: n2) 43 | deriving instance (Namespace n1, Namespace n2) => Ord (n1 :+: n2) 44 | 45 | instance (Namespace n1, Namespace n2) => NFData (n1 :+: n2) where 46 | rnf (LeftName a) = rnf a 47 | rnf (RightName a) = rnf a 48 | 49 | instance (Namespace n1, Namespace n2) => Binary (n1 :+: n2) where 50 | get = do 51 | tg <- getWord8 52 | case tg of 53 | 0 -> liftM LeftName get 54 | 1 -> liftM RightName get 55 | _ -> error "get{(:+:) n1 n2}: unknown tag" 56 | put (LeftName n1) = putWord8 0 >> put n1 57 | put (RightName n2) = putWord8 1 >> put n2 58 | 59 | 60 | data UnionEntry n1 n2 = LeftEntry (Entry n1) | RightEntry (Entry n2) 61 | 62 | fromLeftEntry :: UnionEntry n1 n2 -> Maybe (Entry n1) 63 | fromLeftEntry = \n -> case n of RightEntry _ -> Nothing; LeftEntry n1 -> Just n1 64 | 65 | fromRightEntry :: UnionEntry n1 n2 -> Maybe (Entry n2) 66 | fromRightEntry = \n -> case n of LeftEntry _ -> Nothing; RightEntry n2 -> Just n2 67 | 68 | deriving instance (Namespace n1, Namespace n2) => Eq (UnionEntry n1 n2) 69 | 70 | instance (Namespace n1, Namespace n2) => Show (UnionEntry n1 n2) where 71 | show (LeftEntry e1) = show e1 72 | show (RightEntry e2) = show e2 73 | 74 | instance (Namespace n1, Namespace n2) => NFData (UnionEntry n1 n2) where 75 | rnf (LeftEntry a) = rnf a 76 | rnf (RightEntry a) = rnf a 77 | 78 | instance (Namespace n1, Namespace n2) => Binary (UnionEntry n1 n2) where 79 | get = do 80 | tg <- getWord8 81 | case tg of 82 | 0 -> liftM LeftEntry get 83 | 1 -> liftM RightEntry get 84 | _ -> error "get{UnionEntry n1 n2}: unknown tag" 85 | put (LeftEntry e1) = putWord8 0 >> put e1 86 | put (RightEntry e2) = putWord8 1 >> put e2 87 | 88 | 89 | instance (Namespace n1, Namespace n2) => Namespace (n1 :+: n2) where 90 | type Entry (n1 :+: n2) = UnionEntry n1 n2 91 | 92 | sanityCheck (LeftName n1) (LeftEntry e1) = sanityCheck n1 e1 93 | sanityCheck (RightName n2) (RightEntry e2) = sanityCheck n2 e2 94 | sanityCheck _ _ = return $ Just "Mismatched name/entry structure" 95 | 96 | defaultRule (LeftName n1) = liftRule' (fromLeftName, fromLeftEntry) (LeftName, LeftEntry) defaultRule (LeftName n1) 97 | defaultRule (RightName n2) = liftRule' (fromRightName, fromRightEntry) (RightName, RightEntry) defaultRule (RightName n2) 98 | 99 | data Snapshot (n1 :+: n2) = UnionSnapshot (Snapshot n1) (Snapshot n2) 100 | 101 | takeSnapshot = liftM2 UnionSnapshot takeSnapshot takeSnapshot 102 | lintSnapshots building_ns sss = lintSnapshots building_ns1 [(ss1, ss1', fst (partitionNames ns)) | (UnionSnapshot ss1 _ss2, UnionSnapshot ss1' _ss2', ns) <- sss] ++ lintSnapshots building_ns2 [(ss2, ss2', snd (partitionNames ns)) | (UnionSnapshot _ss1 ss2, UnionSnapshot _ss1' ss2', ns) <- sss] 103 | where (building_ns1, building_ns2) = partitionNames building_ns 104 | 105 | partitionNames :: [n1 :+: n2] -> ([n1], [n2]) 106 | partitionNames ns = ([n1 | LeftName n1 <- ns], [n2 | RightName n2 <- ns]) 107 | 108 | 109 | -- | It is occasionally useful to have a "unit" namespace that is a subtype of everything. There are no (non-bottom) names of this type. 110 | data Empty 111 | 112 | deriving instance Eq Empty 113 | deriving instance Ord Empty 114 | deriving instance Show Empty 115 | 116 | instance Binary Empty where 117 | get = return (error "Forced a deserialized Empty thunk") 118 | put _ = return () 119 | 120 | instance NFData Empty 121 | 122 | instance Namespace Empty where 123 | type Entry Empty = Empty 124 | data Snapshot Empty = EmptySnapshot 125 | takeSnapshot = return EmptySnapshot 126 | lintSnapshots _ _ = [] 127 | 128 | 129 | liftRule :: (nsub :< nsup) => Rule' ntop nsub -> Rule' ntop nsup 130 | liftRule = liftRule' downcast upcast 131 | 132 | liftRule' :: (nsup -> Maybe nsub, Entry nsup -> Maybe (Entry nsub)) 133 | -> (nsub -> nsup, Entry nsub -> Entry nsup) 134 | -> Rule' ntop nsub -> Rule' ntop nsup 135 | liftRule' (down_name, _down_entry) (up_name, up_entry) rule ntop = case down_name ntop of 136 | Nothing -> return Nothing 137 | Just n -> liftM (fmap (\(creates, act) -> (map up_name creates, liftM (map up_entry) act))) $ rule n 138 | 139 | 140 | class (:<) nsub nsup where 141 | downcast :: (nsup -> Maybe nsub, Entry nsup -> Maybe (Entry nsub)) 142 | upcast :: (nsub -> nsup, Entry nsub -> Entry nsup) -- Stuff the two functions together to sidestep non-injectivitity of Entry 143 | 144 | instance (:<) n n where 145 | downcast = (Just, Just) 146 | upcast = (id, id) 147 | 148 | -- Due to limitations of the Haskell inference machinery, we implement right-biased 149 | -- search of namespaces composed with (:+:). Left branches match only by direct unification: 150 | instance (:<) n1 (n1 :+: n2) where 151 | downcast = (fromLeftName, fromLeftEntry) 152 | upcast = (LeftName, LeftEntry) 153 | 154 | -- We do full search in the right hand subtree: 155 | instance ((:<) n1 n3) => (:<) n1 (n2 :+: n3) where 156 | downcast = (\n -> fromRightName n >>= name, \e -> fromRightEntry e >>= entry) 157 | where (name, entry) = downcast 158 | upcast = (RightName . name, RightEntry . entry) 159 | where (name, entry) = upcast 160 | 161 | -- This is a more "experimental" instance that gives us full "width subtyping". We *have* to expand 162 | -- the second parameter to (n3 :+: n4) or it ambiguously overlaps with the rule above. Luckily this 163 | -- doesn't make the rule less applicable, because you shouldn't be trying to make (n1 :+: n2) a subtype 164 | -- of a non-(:+:) type. The only case where that would even make sense is (n1 == n2), which is degenerate. 165 | instance ((:<) n1 (n3 :+: n4), (:<) n2 (n3 :+: n4)) => (:<) (n1 :+: n2) (n3 :+: n4) where 166 | downcast = (\n -> fmap LeftName (name1 n) `mplus` fmap RightName (name2 n), \e -> fmap LeftEntry (entry1 e) `mplus` fmap RightEntry (entry2 e)) 167 | where (name1, entry1) = downcast 168 | (name2, entry2) = downcast 169 | upcast = (\n -> case n of LeftName n1 -> name1 n1; RightName n2 -> name2 n2, \e -> case e of LeftEntry e1 -> entry1 e1; RightEntry e2 -> entry2 e2) 170 | where (name1, entry1) = upcast 171 | (name2, entry2) = upcast 172 | 173 | instance (:<) Empty n where 174 | downcast = (const Nothing, const Nothing) 175 | upcast = (\_ -> error "Forced an upcasted Empty", \_ -> error "Forced an upcasted Empty entry") 176 | 177 | 178 | need :: forall ntop n. (n :< ntop, Namespace ntop) => [n] -> Act ntop [Entry n] 179 | need ns = do 180 | top_es <- Core.need $ map up_name ns 181 | let Just es = mapM down_entry top_es 182 | return es 183 | where (_down_name :: ntop -> Maybe n, down_entry) = downcast 184 | (up_name :: n -> ntop, _up_entry) = upcast 185 | 186 | query :: (n :< ntop, Namespace ntop) => n -> Act ntop (Entry n) 187 | query n = fmap (\[e] -> e) $ need [n] 188 | -------------------------------------------------------------------------------- /tests/Test.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | \begin{code} 4 | import Control.Concurrent 5 | import Control.Concurrent.MVar 6 | 7 | import qualified Control.Exception as Exception 8 | import Control.Monad 9 | 10 | import System.Environment 11 | import System.Directory 12 | import System.Exit 13 | import System.FilePath 14 | import System.Process 15 | import System.Timeout 16 | 17 | import System.IO 18 | import System.IO.Temp 19 | 20 | import Data.List 21 | 22 | import Debug.Trace 23 | 24 | 25 | withCurrentDirectory :: FilePath -> IO a -> IO a 26 | withCurrentDirectory new_cwd act = Exception.bracket (do { old_cwd <- getCurrentDirectory; setCurrentDirectory new_cwd; return old_cwd }) setCurrentDirectory (\_ -> act) 27 | 28 | isExitFailure :: ExitCode -> Bool 29 | isExitFailure (ExitFailure _) = True 30 | isExitFailure _ = False 31 | 32 | doWhile_ :: IO a -> IO Bool -> IO () 33 | doWhile_ what test = go 34 | where go = what >> test >>= \b -> if b then go else return () 35 | 36 | removeFileIfExists :: FilePath -> IO () 37 | removeFileIfExists fp = doesFileExist fp >>= \exists -> when exists (removeFile fp) 38 | 39 | touch :: FilePath -> IO () 40 | touch fp = runProcess "touch" [fp] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess >> return () 41 | 42 | ms = (*1000) 43 | seconds = (*1000000) 44 | 45 | traceShowM :: (Monad m, Show a) => m a -> m a 46 | traceShowM mx = mx >>= \x -> trace (show x) (return x) 47 | 48 | fst3 :: (a, b, c) -> a 49 | fst3 (a, _, _) = a 50 | 51 | 52 | assertEqualM :: (Eq a, Show a, Monad m) => a -> a -> m () 53 | assertEqualM expected actual = if expected == actual then return () else fail $ show expected ++ " /= " ++ show actual 54 | 55 | assertEqualFileM :: FilePath -> String -> IO () 56 | assertEqualFileM fp_expected actual = readFile fp_expected >>= \expected -> assertEqualM expected actual 57 | 58 | assertIsM :: (Show a, Monad m) => (a -> Bool) -> a -> m () 59 | assertIsM expectation actual = if expectation actual then return () else fail $ show actual ++ " did not match our expectations" 60 | 61 | clean :: [FilePath] -> IO () 62 | clean = mapM_ removeFileIfExists 63 | 64 | -- | Allows us to timeout even blocking that is not due to the Haskell RTS, by running the action to time out on 65 | -- another thread. 66 | timeoutForeign :: Int -> IO () -> IO a -> IO (Maybe a) 67 | timeoutForeign microsecs cleanup act = flip Exception.finally cleanup $ do 68 | mvar <- newEmptyMVar 69 | forkIO $ act >>= putMVar mvar -- NB: leaves the foreign thing running even once the timeout has passed! 70 | timeout microsecs $ takeMVar mvar 71 | 72 | shake_ :: FilePath -> [String] -> IO ExitCode 73 | shake_ fp args = fmap fst3 $ shake fp args 74 | 75 | shake :: FilePath -> [String] -> IO (ExitCode, String, String) 76 | shake fp args = {- (\res@(ec, stdout, stderr) -> putStrLn stdout >> putStrLn stderr >> return res) =<< -} do 77 | extra_args <- getArgs -- NB: this is a bit of a hack! 78 | 79 | (_h_stdin, h_stdout, h_stderr, ph) <- runInteractiveProcess "runghc" (["-i../../", fp] ++ args ++ extra_args) Nothing Nothing 80 | mb_ec <- timeoutForeign (seconds 10) (terminateProcess ph) $ waitForProcess ph 81 | out <- hGetContents h_stdout 82 | err <- hGetContents h_stderr 83 | 84 | when ("-v" `elem` extra_args) $ do 85 | hPutStrLn stdout out 86 | hPutStrLn stderr err 87 | 88 | case mb_ec of 89 | Nothing -> error "shake took too long to run!" 90 | Just ec -> return (ec, out, err) 91 | 92 | -- | Shake can only detect changes that are reflected by changes to the modification time. 93 | -- Thus if we expect a rebuild we need to wait for the modification time used by the system to actually change. 94 | waitForModificationTimeToChange :: IO () 95 | waitForModificationTimeToChange = withSystemTempDirectory "openshake-test" $ \tmpdir -> do 96 | let testfile = tmpdir "modtime.txt" 97 | writeFile testfile "" 98 | init_mod_time <- getModificationTime testfile 99 | mb_unit <- timeout (seconds 5) $ (threadDelay (seconds 1) >> writeFile testfile "") `doWhile_` (fmap (== init_mod_time) (getModificationTime testfile)) 100 | case mb_unit of 101 | Nothing -> error "The modification time doesn't seem to be changing" 102 | Just () -> return () 103 | 104 | mtimeSanityCheck :: IO () 105 | mtimeSanityCheck = flip Exception.finally (removeFileIfExists "delete-me") $ do 106 | writeFile "delete-me" "" 107 | mtime1 <- getModificationTime "delete-me" 108 | threadDelay (seconds 2) 109 | 110 | writeFile "delete-me" "" 111 | mtime2 <- getModificationTime "delete-me" 112 | threadDelay (seconds 2) 113 | 114 | touch "delete-me" 115 | mtime3 <- getModificationTime "delete-me" 116 | threadDelay (seconds 2) 117 | 118 | True `assertEqualM` (mtime1 /= mtime2 && mtime2 /= mtime3 && mtime1 /= mtime3) 119 | 120 | withTest :: FilePath -> [FilePath] -> IO () -> IO () 121 | withTest dir clean_fps act = do 122 | want_tests <- liftM (filter (not . (== '-') . head)) getArgs 123 | let should_run_test = null want_tests || dir `elem` want_tests 124 | 125 | when should_run_test $ do 126 | putStr $ dir ++ ": " 127 | withCurrentDirectory dir $ do 128 | clean (".openshake-db":clean_fps) 129 | act 130 | putStrLn "[OK]" 131 | 132 | simpleTest :: FilePath -> FilePath -> String -> IO () 133 | simpleTest shakefile main expect_out = do 134 | -- 1) Do the build 135 | ec <- shake_ shakefile [] 136 | ExitSuccess `assertEqualM` ec 137 | 138 | -- 2) Check the EXE is OK 139 | out <- readProcess main [] "" 140 | expect_out`assertEqualM` out 141 | 142 | main :: IO () 143 | main = do 144 | mtimeSanityCheck 145 | 146 | withTest "ambiguous-rules" ["foo"] $ do 147 | ec <- shake_ "Shakefile.hs" [] 148 | ExitSuccess `assertEqualM` ec 149 | 150 | x <- readFile "foo" 151 | "First rule" `assertEqualM` x 152 | 153 | withTest "lexical-scope" ["examplefile"] $ do 154 | ec <- shake_ "Shakefile.hs" [] 155 | ExitSuccess `assertEqualM` ec 156 | 157 | withTest "simple-c" ["Main", "main.o", "constants.h"] $ do 158 | -- 1) Try a normal build. The first time around is a clean build, the second time we 159 | -- have to rebuild even though we already have Main: 160 | forM_ [42, 43] $ \constant -> do 161 | writeFile "constants.h" $ "#define MY_CONSTANT " ++ show constant 162 | 163 | ec <- shake_ "Shakefile.hs" [] 164 | ExitSuccess `assertEqualM` ec 165 | 166 | out <- readProcess "./Main" [] "" 167 | ("The magic number is " ++ show constant ++ "\n") `assertEqualM` out 168 | 169 | waitForModificationTimeToChange 170 | 171 | -- 2) Run without changing any files, to make sure that nothing gets spuriously rebuilt: 172 | let interesting_files = ["Main", "main.o"] 173 | old_mtimes <- mapM getModificationTime interesting_files 174 | ec <- shake_ "Shakefile.hs" [] 175 | ExitSuccess `assertEqualM` ec 176 | new_mtimes <- mapM getModificationTime interesting_files 177 | old_mtimes `assertEqualM` new_mtimes 178 | 179 | -- 3) Corrupt the database and check that Shake recovers 180 | writeFile ".openshake-db" "Junk!" 181 | ec <- shake_ "Shakefile.hs" [] 182 | ExitSuccess `assertEqualM` ec 183 | 184 | -- TODO: test that nothing goes wrong if we change the type of oracle between runs 185 | 186 | withTest "simple-hs" ["Main", "Main.hi", "Main.o", "Utility.hi", "Utility.o"] $ do 187 | simpleTest "Shakefile.hs" "./Main" "2\n" 188 | 189 | withTest "evan-hang" ["main", "App/Main.hi", "App/Main.o", "Util/Regex.hi", "Util/Regex.o"] $ do 190 | -- The problem here manifested itself when doing a build on a tree just built from clean 191 | simpleTest "Shakefile.hs" "./main" "\"I'm a regex module!\"\n" 192 | simpleTest "Shakefile.hs" "./main" "\"I'm a regex module!\"\n" 193 | 194 | withTest "deserialization-changes" ["examplefile"] $ do 195 | -- 1) First run has no database, so it is forced to create the file 196 | ec <- shake_ "Shakefile-1.hs" [] 197 | ExitSuccess `assertEqualM` ec 198 | 199 | x <- readFile "examplefile" 200 | "OK1" `assertEqualM` x 201 | 202 | -- 2) The second run has a "corrupt" database because answer serialisation is shorter 203 | ec <- shake_ "Shakefile-2.hs" [] 204 | ExitSuccess `assertEqualM` ec 205 | 206 | x <- readFile "examplefile" 207 | "OK2" `assertEqualM` x 208 | 209 | -- 2) The second run has a "corrupt" database because question serialisation is longer 210 | ec <- shake_ "Shakefile-3.hs" [] 211 | ExitSuccess `assertEqualM` ec 212 | 213 | x <- readFile "examplefile" 214 | "OK3" `assertEqualM` x 215 | 216 | withTest "cyclic" [] $ do 217 | ec <- shake_ "Shakefile.hs" [] 218 | isExitFailure `assertIsM` ec 219 | 220 | withTest "cyclic-harder" [] $ do 221 | ec <- shake_ "Shakefile.hs" [] 222 | isExitFailure `assertIsM` ec 223 | 224 | withTest "creates-directory-implicitly" ["subdirectory" "foo"] $ do 225 | -- Even though our rule does not create the directory it is building into it should succeed 226 | ec <- shake_ "Shakefile.hs" [] 227 | ExitSuccess `assertEqualM` ec 228 | 229 | withTest "lazy-exceptions" ["foo-dependency3"] $ do 230 | (ec, _stdout, stderr) <- shake "Shakefile.hs" ["-k"] 231 | 232 | -- All exceptions should be reported 233 | isExitFailure `assertIsM` ec 234 | (\x -> all (`isInfixOf` x) ["No rule to build", "User error in foo-dependency2", "User error in bar rule"]) `assertIsM` stderr 235 | 236 | -- We should have managed to build one of the things needed even though everything else died 237 | doesFileExist "foo-dependency3" >>= assertEqualM True 238 | 239 | withTest "lint" ["access-without-need", "access-before-need", "need-without-access"] $ do 240 | (ec, _stdout, stderr) <- shake "Shakefile.hs" ["--lint"] 241 | 242 | -- All exceptions should be reported 243 | ExitSuccess `assertEqualM` ec 244 | "lint.stderr" `assertEqualFileM` stderr 245 | 246 | \end{code} -------------------------------------------------------------------------------- /Development/Shake/Files.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, GeneralizedNewtypeDeriving, FlexibleContexts, TupleSections, CPP #-} 2 | module Development.Shake.Files ( 3 | -- * File modification times 4 | ModTime, getFileModTime, 5 | 6 | -- * Normalised file paths 7 | CanonicalFilePath, canonical, 8 | 9 | -- * Rules for building files 10 | CreatesFiles, Rule, 11 | (*>), (*@>), (**>), (**@>), (?>), (?@>), addRule, 12 | 13 | -- * Requesting that files get built 14 | need, want 15 | ) where 16 | 17 | import Development.Shake.Core hiding (Rule, addRule, need) 18 | import qualified Development.Shake.Core as Core 19 | import Development.Shake.Core.Binary 20 | import Development.Shake.Core.Utilities 21 | import Development.Shake.Composition hiding (need) 22 | import qualified Development.Shake.Composition as Composition 23 | 24 | import Data.Binary 25 | 26 | import Control.DeepSeq 27 | 28 | import Control.Monad 29 | import Control.Monad.IO.Class 30 | 31 | import Data.Traversable (Traversable(traverse)) 32 | 33 | import Data.Int (Int64) 34 | import Data.List 35 | import Data.List.Split (splitOn) 36 | import qualified Data.Map as M 37 | import qualified Data.Set as S 38 | import Data.Time.Clock (UTCTime) 39 | import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) 40 | 41 | import System.Directory 42 | import System.Directory.AccessTime 43 | import System.FilePath (takeDirectory, equalFilePath, makeRelative, ()) 44 | import System.FilePath.Glob 45 | import System.Time (ClockTime(..)) 46 | 47 | 48 | type ModTime = UTCTime 49 | 50 | -- TODO: remove orphan instance 51 | instance Binary UTCTime where 52 | get = getModTime 53 | put = putModTime 54 | 55 | getModTime :: Get ModTime 56 | getModTime = fmap (posixSecondsToUTCTime . (/ 1000) . fromIntegral) (get :: Get Int64) 57 | 58 | putModTime :: ModTime -> Put 59 | putModTime mtime = put (round (utcTimeToPOSIXSeconds mtime * 1000) :: Int64) 60 | 61 | getFileModTime :: FilePath -> IO (Maybe ModTime) 62 | getFileModTime fp = handleDoesNotExist (return Nothing) (fmap Just (getModificationTime fp)) 63 | 64 | 65 | data CanonicalFilePath = UnsafeCanonicalise { originalFilePath :: FilePath, canonicalFilePath :: FilePath } 66 | 67 | instance Show CanonicalFilePath where 68 | show = originalFilePath -- TODO: confirm that Show is only used in errors, and use Pretty instead? 69 | 70 | instance Eq CanonicalFilePath where 71 | cfp1 == cfp2 = canonicalFilePath cfp1 `equalFilePath` canonicalFilePath cfp2 72 | 73 | instance Ord CanonicalFilePath where 74 | cfp1 `compare` cfp2 = canonicalFilePath cfp1 `compare` canonicalFilePath cfp2 75 | 76 | instance NFData CanonicalFilePath where 77 | rnf (UnsafeCanonicalise a b) = rnf a `seq` rnf b 78 | 79 | instance Binary CanonicalFilePath where 80 | get = liftM2 UnsafeCanonicalise getUTF8String getUTF8String 81 | put (UnsafeCanonicalise fp1 fp2) = putUTF8String fp1 >> putUTF8String fp2 82 | 83 | 84 | canonical :: FilePath -> IO CanonicalFilePath 85 | canonical fp = do 86 | exists <- liftM2 (||) (doesFileExist fp) (doesDirectoryExist fp) 87 | if exists 88 | then fmap (UnsafeCanonicalise fp) $ canonicalizePath fp 89 | else fmap (UnsafeCanonicalise fp . approximateCanonicalize . ( fp)) getCurrentDirectory 90 | 91 | -- Used for non-existant filenames. Consequently, can only be approximately correct! 92 | -- Nonetheless, it's important that we make some sort of guess here, or else we get 93 | -- ridiculous behaviour like rules for ./Foo.hs not matching requests for ./Bar/../Foo.hs 94 | -- simply because Foo.hs doesn't yet exist. 95 | approximateCanonicalize :: FilePath -> FilePath 96 | approximateCanonicalize = intercalate [head seperators] . go 0 [] . splitOn seperators 97 | where 98 | go n acc [] = replicate n ".." ++ reverse acc 99 | go n acc ("." :xs) = go n acc xs 100 | go n [] ("..":xs) = go (n+1) [] xs 101 | go n (_:acc) ("..":xs) = go n acc xs 102 | go n acc (x :xs) = go n (x:acc) xs 103 | #ifdef WINDOWS 104 | seperators = "\\/" 105 | #else 106 | seperators = "/" 107 | #endif 108 | 109 | instance Namespace CanonicalFilePath where 110 | type Entry CanonicalFilePath = ModTime 111 | 112 | -- In standard Shake, we would: 113 | -- * Not sanity check anything 114 | -- * Recover the ModTime by looking at the file modification time 115 | -- * And hence dependent files would be rebuilt but the file would not be, even if the modification time had changed since the last run 116 | -- 117 | -- In OpenShake, we would: 118 | -- * Cache the ModTime 119 | -- * Sanity check the current ModTime against the current one 120 | -- * Thus we detect changes in this file since the last run, so changed files will be rebuilt even if their dependents haven't changed 121 | sanityCheck fp old_mtime = getFileModTime (canonicalFilePath fp) >>= \mb_new_mtime -> return $ guard (mb_new_mtime /= Just old_mtime) >> Just "the file has been modified (or deleted) even though its dependents have not changed" 122 | 123 | defaultRule fp = do 124 | -- Not having a rule might still be OK, as long as there is some existing file here: 125 | mb_nested_time <- getFileModTime (canonicalFilePath fp) 126 | case mb_nested_time of 127 | Nothing -> return Nothing 128 | -- NB: it is important that this fake oracle is not reachable if we change from having a rule for a file to not having one, 129 | -- but the file still exists. In that case we will try to recheck the old oracle answers against our new oracle and the type 130 | -- check will catch the change. 131 | Just nested_time -> return $ Just ([fp], return [nested_time]) -- TODO: distinguish between files created b/c of rule match and b/c they already exist in history? Lets us rebuild if the reason changes. 132 | 133 | data Snapshot CanonicalFilePath = CFPSS { unCFPSS :: M.Map CanonicalFilePath ClockTime } 134 | 135 | takeSnapshot = do 136 | cwd <- getCurrentDirectory >>= canonical 137 | (_, fps) <- explore cwd (S.empty, S.empty) "." 138 | liftM (CFPSS . M.fromAscList) $ forM (S.toAscList fps) $ \fp -> liftM (fp,) (getAccessTime (canonicalFilePath fp)) 139 | where 140 | explore parent_fp (seen, seen_files) fp = do 141 | fp <- canonical fp 142 | if fp `S.member` seen || not (canonicalFilePath parent_fp `isPrefixOf` canonicalFilePath fp) -- Must prevent explore following ".." downwards to the root file system! 143 | then return (seen, seen_files) 144 | else do 145 | let seen' = S.insert fp seen 146 | is_file <- doesFileExist (canonicalFilePath fp) 147 | if is_file 148 | then return (seen', S.insert fp seen_files) 149 | else getDirectoryContents (canonicalFilePath fp) >>= (foldM (explore fp) (seen', seen_files) . map (originalFilePath fp )) 150 | 151 | -- TODO: I could lint modification times as well? For example, you should probably not modify a file you need 152 | lintSnapshots building_fps = go S.empty S.empty S.empty 153 | where 154 | go needed accessed accessed_without_need history = case history of 155 | [] -> [show fp ++ " was accessed without 'need'ing it first" | fp <- S.toList (accessed_without_need S.\\ S.fromList building_fps)] ++ 156 | [show fp ++ " was 'need'ed without ever being accessed" | not (null building_fps), fp <- S.toList needed_without_access] 157 | -- It is OK to need something "uselessly" at the top level, hence the check against building_fps here 158 | where -- 2) We should not "need" files that we never access 159 | needed_without_access = needed S.\\ accessed 160 | ((ss, ss', needs):history') -> go -- a) In the successor, it is now OK to access anything we just "need"ed 161 | (needed `S.union` S.fromList needs) 162 | -- b) In the successor, we need not warn about over-needing those things we have just accessed 163 | (accessed `S.union` accesses) 164 | -- 1) We should not be allowed to access files that we didn't "need" or are building 165 | (accessed_without_need `S.union` (accesses S.\\ needed)) 166 | history' 167 | where 168 | (_ss_deleted, ss_continued, _ss_created) = zipMaps (unCFPSS ss) (unCFPSS ss') 169 | accesses = M.keysSet $ M.filter (\(atime1, atime2) -> atime1 < atime2) ss_continued 170 | -- 3) We should not create files there are rules for but are not in our "also" list 171 | -- FIXME 172 | -- 4) We should not delete files there are rules for 173 | -- FIXME 174 | 175 | 176 | zipMaps :: Ord k => M.Map k v -> M.Map k v -> (M.Map k v, M.Map k (v, v), M.Map k v) 177 | zipMaps m1 m2 = (m1 `M.difference` m2, M.intersectionWith (,) m1 m2, m2 `M.difference` m1) 178 | 179 | 180 | type CreatesFiles = [FilePath] 181 | type Rule ntop o = FilePath -> Maybe (CreatesFiles, Act ntop ()) 182 | 183 | (*>) :: (CanonicalFilePath :< ntop, Namespace ntop) 184 | => String -> (FilePath -> Act ntop ()) -> Shake ntop () 185 | (*>) pattern action = (compiled `match`) ?> action 186 | where compiled = compile pattern 187 | 188 | (*@>) :: (CanonicalFilePath :< ntop, Namespace ntop) 189 | => (String, CreatesFiles) -> (FilePath -> Act ntop ()) -> Shake ntop () 190 | (*@>) (pattern, alsos) action = (\fp -> guard (compiled `match` fp) >> return alsos) ?@> action 191 | where compiled = compile pattern 192 | 193 | (**>) :: (CanonicalFilePath :< ntop, Namespace ntop) 194 | => (FilePath -> Maybe a) -> (FilePath -> a -> Act ntop ()) -> Shake ntop () 195 | (**>) p action = addRule $ \fp -> p fp >>= \x -> return ([fp], action fp x) 196 | 197 | (**@>) :: (CanonicalFilePath :< ntop, Namespace ntop) 198 | => (FilePath -> Maybe ([FilePath], a)) -> (FilePath -> a -> Act ntop ()) -> Shake ntop () 199 | (**@>) p action = addRule $ \fp -> p fp >>= \(creates, x) -> return (creates, action fp x) 200 | 201 | (?>) :: (CanonicalFilePath :< ntop, Namespace ntop) 202 | => (FilePath -> Bool) -> (FilePath -> Act ntop ()) -> Shake ntop () 203 | (?>) p action = addRule $ \fp -> guard (p fp) >> return ([fp], action fp) 204 | 205 | (?@>) :: (CanonicalFilePath :< ntop, Namespace ntop) 206 | => (FilePath -> Maybe CreatesFiles) -> (FilePath -> Act ntop ()) -> Shake ntop () 207 | (?@>) p action = addRule $ \fp -> p fp >>= \creates -> return (creates, action fp) 208 | 209 | addRule :: (CanonicalFilePath :< ntop, Namespace ntop) => Rule ntop o -> Shake ntop () 210 | addRule rule = Core.addRule $ liftRule $ \fp -> do 211 | cwd <- getCurrentDirectory 212 | flip traverse (rule (makeRelative cwd (canonicalFilePath fp))) $ \(creates, act) -> do 213 | creates <- mapM (canonical . (cwd )) creates 214 | return (creates, mapM_ (liftIO . createDirectoryIfMissing True . takeDirectory . canonicalFilePath) creates >> act >> mapM (liftIO . getCleanFileModTime . canonicalFilePath) creates) 215 | where 216 | getCleanFileModTime :: FilePath -> IO ModTime 217 | getCleanFileModTime fp = getFileModTime fp >>= maybe (shakefileError $ "The rule did not create a file that it promised to create " ++ fp) return 218 | 219 | 220 | need :: (CanonicalFilePath :< ntop, Namespace ntop) => [FilePath] -> Act ntop () 221 | need fps = liftIO (mapM canonical fps) >>= Composition.need >> return () 222 | 223 | -- | Attempt to build the specified files once are done collecting rules in the 'Shake' monad. 224 | -- There is no guarantee about the order in which files will be built: in particular, files mentioned in one 225 | -- 'want' will not necessarily be built before we begin building files in the following 'want'. 226 | want :: (CanonicalFilePath :< ntop, Namespace ntop) => [FilePath] -> Shake ntop () 227 | want = act . need -------------------------------------------------------------------------------- /Development/Shake/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeFamilies, ExistentialQuantification, Rank2Types, FlexibleInstances, FlexibleContexts #-} 3 | {-# LANGUAGE TypeSynonymInstances, StandaloneDeriving, TupleSections #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} -- For Exception only 5 | module Development.Shake.Core ( 6 | -- * The top-level monadic interface 7 | Shake, shake, shakeWithOptions, 8 | ShakeOptions(..), defaultShakeOptions, 9 | 10 | -- * Adding rules in the Shake monad and controlling their visibility 11 | addRule, privateTo, privateTo_, 12 | 13 | -- * Setting up initial actions 14 | act, 15 | 16 | -- * Rules 17 | Rule, Rule', Generator, Generator', 18 | 19 | -- * Verbosity and command-line output from Shake 20 | Verbosity(..), actVerbosity, putStrLnAt, 21 | 22 | -- * The monadic interface used by rule bodies 23 | Act, need, 24 | 25 | -- * Namespaces 26 | Namespace(..), 27 | 28 | -- * Specialised errors 29 | shakefileError, internalError, 30 | 31 | -- * Used to add commands to the shake report 32 | reportCommand 33 | ) where 34 | 35 | import Development.Shake.Core.Binary 36 | import Development.Shake.Core.WaitHandle 37 | import Development.Shake.Core.Utilities 38 | 39 | import Data.Binary 40 | import Data.Binary.Get 41 | import Data.Binary.Put 42 | import qualified Data.ByteString.Lazy as BS 43 | 44 | import Data.Typeable (Typeable) -- For Exception only 45 | 46 | import Control.Applicative (Applicative(..)) 47 | import Control.Arrow (first, second) 48 | 49 | import Control.Concurrent.MVar 50 | import Control.Concurrent.ParallelIO.Local (Pool) 51 | import qualified Control.Concurrent.ParallelIO.Local as Parallel 52 | 53 | import Control.DeepSeq 54 | import qualified Control.Exception.Peel as Exception 55 | 56 | import Control.Monad 57 | import qualified Control.Monad.Trans.Reader as Reader 58 | import qualified Control.Monad.Trans.State as State 59 | import Control.Monad.Trans.Class (MonadTrans(..)) 60 | import Control.Monad.IO.Class 61 | import Control.Monad.IO.Peel 62 | 63 | -- import Data.Set (Set) 64 | -- import qualified Data.Set as S 65 | import Data.Either 66 | import Data.Map (Map) 67 | import qualified Data.Map as M 68 | import Data.Maybe 69 | import Data.Ord 70 | import Data.List 71 | import Data.Time.Clock (UTCTime, NominalDiffTime, getCurrentTime, diffUTCTime) 72 | import Data.Foldable (traverse_) 73 | 74 | import System.Environment 75 | import System.IO 76 | import System.IO.Unsafe (unsafePerformIO) -- For command line parsing hack only 77 | 78 | import GHC.Conc (numCapabilities) 79 | 80 | 81 | -- | Verbosity level: higher is more verbose. Levels are as follows: 82 | -- 83 | -- 0: Silent 84 | -- 1: Quiet 85 | -- 2: Normal 86 | -- 3: Verbose 87 | -- 4: Chatty 88 | data Verbosity = SilentVerbosity | QuietVerbosity | NormalVerbosity | VerboseVerbosity | ChattyVerbosity 89 | deriving (Show, Enum, Bounded, Eq, Ord) 90 | 91 | 92 | data ShakefileException = RuleError String | forall e. Exception.Exception e => ActionError e | RecursiveError [([String], ShakefileException)] 93 | deriving (Typeable) 94 | 95 | instance Show ShakefileException where 96 | show = unlines . showShakefileException 97 | 98 | showShakefileException :: ShakefileException -> [String] 99 | showShakefileException (RuleError s) = ["Error in rule definition: " ++ s] 100 | showShakefileException (ActionError e) = ["Error in rule action: " ++ show e] 101 | showShakefileException (RecursiveError sfes) = "Error due to dependents:" : concatMap (\(fps, sfe) -> (' ' : showStringList fps ++ ":") : map (" " ++) (showShakefileException sfe)) sfes 102 | 103 | instance NFData ShakefileException where 104 | rnf (RuleError a) = rnf a 105 | rnf (ActionError a) = a `seq` () 106 | rnf (RecursiveError a) = rnf a 107 | 108 | instance Exception.Exception ShakefileException 109 | 110 | 111 | shakefileError :: String -> IO a 112 | shakefileError s = Exception.throwIO $ RuleError s 113 | 114 | internalError :: String -> a 115 | internalError s = error $ "Internal Shake error: " ++ s 116 | 117 | 118 | runGetAll :: Get a -> BS.ByteString -> a 119 | runGetAll act bs = case runGetState act bs 0 of (x, bs', _) -> if BS.length bs' == 0 then x else error $ show (BS.length bs') ++ " unconsumed bytes after reading" 120 | 121 | 122 | class (Ord n, Eq (Entry n), 123 | Show n, Show (Entry n), 124 | Binary n, Binary (Entry n), 125 | NFData n, NFData (Entry n)) => Namespace n where 126 | type Entry n 127 | 128 | -- | Tests whether the cached value for some Dirty entry still appears to be correct. If it is certainly incorrect, 129 | -- returns a human-readable reason as to why it should be discarded. 130 | -- 131 | -- The default implementation of this function does no sanity checking. 132 | sanityCheck :: n -> Entry n -> IO (Maybe String) 133 | sanityCheck _ _ = return Nothing 134 | 135 | -- | The rule which we fall back on if there are no other options. 136 | -- 137 | -- In order to get the same behaviour as Shake, we allow the default rule to depend on some IO computation (in particular, 138 | -- we need to know whether a file already exists in order to decide if can use the default rule for it). 139 | -- TODO: I could just do the IO in the Act monad and delay the error a little bit. 140 | -- 141 | -- The default implementation is not to have a default rule. 142 | defaultRule :: Rule' ntop n 143 | defaultRule _ = return Nothing 144 | 145 | data Snapshot n 146 | 147 | takeSnapshot :: IO (Snapshot n) 148 | 149 | lintSnapshots :: [n] -- ^ Files that the rule claims to build. An empty list if linting a top-level action. 150 | -> [(Snapshot n, Snapshot n, [n])] -- ^ Sequence of snapshots taken just before and after running rule code, and the list of files needed by the rule code as it exits. 151 | -- The list is in sequential order: earlier fragments of rule code make snapshot tranisitions that appear earlier in the list. 152 | -- The last list of files will always be empty because the rule exits for the last time by returning normally rather than needing anything. 153 | -> [String] -- ^ Rule lint errors, if any 154 | 155 | 156 | type Rule' ntop n = n -> IO (Maybe (Generator' ntop n)) 157 | type Rule n = Rule' n n 158 | 159 | data RuleClosure n = RC { 160 | rc_closure :: [[RuleClosure n]], -- ^ Rules closed over. Outermost list represents levels of nested, closly bound rules are near the front. Innermost list represents multiplicity of rules at a level. 161 | rc_rule :: Rule n 162 | } 163 | 164 | type Generator' ntop n = ([n], Act ntop [Entry n]) 165 | type Generator n = Generator' n n 166 | 167 | data ShakeOptions = ShakeOptions { 168 | shakeVerbosity :: Verbosity, -- ^ Verbosity of logging 169 | shakeThreads :: Int, -- ^ Number of simultaneous build actions to run 170 | shakeReport :: Maybe FilePath, -- ^ File to write build report to, if any 171 | shakeContinue :: Bool, -- ^ Attempt to build as much as possible, even if we get exceptions during building 172 | shakeLint :: Bool -- ^ Run the build sequentially, sanity checking user rules at each step 173 | } 174 | 175 | defaultShakeOptions :: ShakeOptions 176 | defaultShakeOptions = ShakeOptions { 177 | shakeVerbosity = unsafePerformIO verbosity, 178 | shakeThreads = numCapabilities, 179 | shakeReport = Just "openshake-report.html", 180 | shakeContinue = unsafePerformIO continue, 181 | shakeLint = unsafePerformIO lint 182 | } 183 | where 184 | -- TODO: when we have more command line options, use a proper command line argument parser. 185 | -- We should also work out whether shake should be doing argument parsing at all, given that it's 186 | -- meant to be used as a library function... 187 | continue = fmap ("-k" `elem`) getArgs 188 | lint = fmap ("--lint" `elem`) getArgs 189 | verbosity = fmap (\args -> fromMaybe NormalVerbosity $ listToMaybe $ reverse [ case rest of "" -> VerboseVerbosity 190 | "v" -> ChattyVerbosity 191 | _ -> toEnum (fromEnum (minBound :: Verbosity) `max` read rest `min` fromEnum (maxBound :: Verbosity)) 192 | | '-':'v':rest <- args ]) getArgs 193 | 194 | 195 | newtype ShakeEnv n = SE { 196 | se_available_rules :: [[RuleClosure n]] -- ^ Presented in corect (non-reversed) order 197 | } 198 | 199 | data ShakeState n = SS { 200 | ss_rules :: [RuleClosure n], -- ^ Accumulated in reverse order 201 | ss_acts :: [([[RuleClosure n]], Act n ())] 202 | } 203 | 204 | newtype Shake n a = Shake { unShake :: State.StateT (ShakeState n) (Reader.Reader (ShakeEnv n)) a } 205 | deriving (Functor, Applicative, Monad) 206 | 207 | runShake :: ShakeEnv n -> ShakeState n -> Shake n a -> (a, ShakeState n) 208 | runShake e s mx = Reader.runReader (State.runStateT (unShake mx) s) e 209 | 210 | -- getShakeState :: Shake n (ShakeState n) 211 | -- getShakeState = Shake (lift State.get) 212 | 213 | -- putShakeState :: ShakeState -> Shake () 214 | -- putShakeState s = Shake (lift (State.put s)) 215 | 216 | asksShakeEnv :: (ShakeEnv n -> a) -> Shake n a 217 | asksShakeEnv extract = Shake $ lift $ Reader.asks extract 218 | 219 | modifyShakeState :: (ShakeState n -> ShakeState n) -> Shake n () 220 | modifyShakeState f = Shake (State.modify f) 221 | 222 | 223 | -- | The rules created by the first action supplied to 'privateTo' will be visible only to 224 | -- themselves and the second action supplied to 'privateTo'. However, any rules created 225 | -- by the second action will be visible both in the outside world and within the first action. 226 | -- 227 | -- Thus, the first action creates rules that are "private" and do not leak out. This can be 228 | -- helpful if you want to override particular 'need' calls with specialised actions. 229 | privateTo :: Shake n a -> (a -> Shake n b) -> Shake n b 230 | privateTo privates private_to = Shake $ State.StateT $ \s -> Reader.reader $ \e -> let (a, s') = Reader.runReader (State.runStateT (unShake privates) (s { ss_rules = [] })) e_private 231 | e_private = e { se_available_rules = reverse (ss_rules s') : se_available_rules e } 232 | in Reader.runReader (State.runStateT (unShake (private_to a)) (s' { ss_rules = ss_rules s })) e_private 233 | 234 | -- | Version of 'privateTo' where the two nested actions don't return anything 235 | privateTo_ :: Shake n () -> Shake n () -> Shake n () 236 | privateTo_ privates private_to = privateTo privates (\() -> private_to) 237 | 238 | 239 | type Database n = MVar (PureDatabase n) 240 | type PureDatabase n = Map n (Status n) 241 | 242 | getPureDatabase :: Namespace n => Get (PureDatabase n) 243 | getPureDatabase = fmap M.fromList $ getList (liftM2 (,) get (liftM2 Dirty getHistory get)) 244 | 245 | putPureDatabase :: Namespace n => PureDatabase n -> Put 246 | putPureDatabase db = putList (\(fp, (hist, cached)) -> put fp >> putHistory hist >> put cached) (M.toList $ M.mapMaybe prepareStatus db) 247 | 248 | 249 | -- NB: we seralize Building as Dirty in case we ever want to serialize the database concurrently 250 | -- with shake actually running. This might be useful to implement e.g. checkpointing... 251 | -- 252 | -- NB: we serialize Clean as Dirty as well. This is because when we reload the database we cannot 253 | -- assume that anything is clean, as one of the things it depends on may have been changed. We have to 254 | -- verify all our assumptions again! 255 | prepareStatus :: Status n -> Maybe (History n, Entry n) 256 | prepareStatus (Building mb_hist _) = mb_hist 257 | prepareStatus (Dirty hist mtime) = Just (hist, mtime) 258 | prepareStatus (Clean hist mtime) = Just (hist, mtime) 259 | prepareStatus (Failed _) = Nothing 260 | 261 | type BuildingWaitHandle n = WaitHandle (Either ShakefileException (Entry n)) -- TODO: record list of files created that we are actually waiting on, for better deadlock errors 262 | 263 | -- NB: use of the Clean constructor is just an optimisation that means we don't have to recursively recheck dependencies 264 | -- whenever a file is need -- instead we can cut the checking process off if we discover than a file is marked as Clean. 265 | -- Of course, this might go a bit wrong if the file becomes invalidated *during a Shake run*, but we accept that risk. 266 | data Status n = Dirty (History n) (Entry n) -- NB: the Dirty entry is only valid if the History has not been invalidated! (Key difference from standard Shake: we cache mtime for Dirty files as well...) 267 | | Clean (History n) (Entry n) 268 | | Building (Maybe (History n, Entry n)) (BuildingWaitHandle n) 269 | | Failed ShakefileException 270 | 271 | deriving instance (Namespace n) => Show (Status n) 272 | 273 | instance Namespace n => NFData (Status n) where 274 | rnf (Dirty a b) = rnf a `seq` rnf b 275 | rnf (Clean a b) = rnf a `seq` rnf b 276 | rnf (Building a b) = rnf a `seq` b `seq` () 277 | rnf (Failed a) = rnf a 278 | 279 | type History n = [QA n] 280 | 281 | getHistory :: Namespace n => Get (History n) 282 | getHistory = getList get 283 | 284 | putHistory :: Namespace n => History n -> Put 285 | putHistory = putList put 286 | 287 | data QA n = Need [(n, Entry n)] 288 | 289 | deriving instance Namespace n => Show (QA n) 290 | 291 | instance Namespace n => NFData (QA n) where 292 | rnf (Need xys) = rnf [rnf x `seq` rnf y | (x, y) <- xys] 293 | 294 | instance Namespace n => Binary (QA n) where 295 | get = liftM Need (getList (liftM2 (,) get get)) 296 | put (Need xes) = putList (\(fp, mtime) -> put fp >> put mtime) xes 297 | 298 | data ActState n = AS { 299 | as_this_history :: History n, 300 | as_snapshots :: [(Snapshot n, Snapshot n, [n])] 301 | } 302 | 303 | data ActEnv n = AE { 304 | ae_would_block_handles :: [WaitHandle ()], -- ^ A list of handles that would be incapable of awakening if the action were to 305 | -- block indefinitely here and now. This is used in the deadlock detector. 306 | ae_rules :: [[RuleClosure n]], 307 | ae_database :: Database n, 308 | ae_wait_database :: MVar (WaitDatabase n), 309 | ae_report :: MVar ReportDatabase, 310 | ae_pool :: Pool, 311 | ae_options :: ShakeOptions 312 | } 313 | 314 | 315 | data Act n a = Act { unAct :: forall m. (MonadLint m, LintNamespace m ~ n) => Reader.ReaderT (ActEnv n) (State.StateT (ActState n) m) a } 316 | 317 | instance Functor (Act n) where 318 | fmap = liftM 319 | 320 | instance Applicative (Act n) where 321 | pure = return 322 | (<*>) = ap 323 | 324 | instance Monad (Act n) where 325 | return x = Act (return x) 326 | Act mx >>= fxmy = Act $ mx >>= \x -> case fxmy x of Act it -> it 327 | 328 | instance MonadIO (Act n) where 329 | liftIO io = Act (liftIO io) 330 | 331 | instance MonadPeelIO (Act n) where 332 | -- Thanks to Anders Kaseorg for this definition (I added a bit of NoLint wrapping to work around the LintNamespace constraint) 333 | peelIO = toAct (liftM (\k (Act mx) -> liftM toAct (k mx)) peelIO) 334 | where 335 | toAct :: Reader.ReaderT (ActEnv n) (State.StateT (ActState n) (NoLint n)) a -> Act n a 336 | toAct mx = Act (Reader.mapReaderT (State.mapStateT (liftIO . unNoLint)) mx) 337 | 338 | 339 | runAct :: (MonadLint m, LintNamespace m ~ n) => ActEnv n -> ActState n -> Act n a -> m (a, ActState n) 340 | runAct e s mx = State.runStateT (Reader.runReaderT (unAct mx) e) s 341 | 342 | -- getActState :: Act ActState 343 | -- getActState = Act (lift State.get) 344 | 345 | -- putActState :: ActState -> Act () 346 | -- putActState s = Act (lift (State.put s)) 347 | 348 | modifyActState :: (ActState n -> ActState n) -> Act n () 349 | modifyActState f = Act (lift (State.modify f)) 350 | 351 | askActEnv :: Act n (ActEnv n) 352 | askActEnv = Act Reader.ask 353 | 354 | actVerbosity :: Act n Verbosity 355 | actVerbosity = fmap (shakeVerbosity . ae_options) askActEnv 356 | 357 | putLog :: MonadIO m => String -> m () 358 | putLog = liftIO . hPutStrLn stderr 359 | 360 | putStrLnAt :: Verbosity -> String -> Act n () 361 | putStrLnAt at_verbosity msg = do 362 | verbosity <- actVerbosity 363 | when (verbosity >= at_verbosity) $ putLog msg 364 | 365 | 366 | -- NB: if you use shake in a nested way bad things will happen to parallelism 367 | -- TODO: make parallelism configurable? 368 | shake :: Namespace n => Shake n () -> IO () 369 | shake = shakeWithOptions defaultShakeOptions 370 | 371 | shakeWithOptions :: forall n. Namespace n => ShakeOptions -> Shake n () -> IO () 372 | shakeWithOptions opts mx = Parallel.withPool (shakeThreads opts) $ \pool -> do 373 | mb_bs <- handleDoesNotExist (return Nothing) $ fmap Just $ BS.readFile ".openshake-db" 374 | db <- case mb_bs of 375 | Nothing -> do 376 | when (shakeVerbosity opts >= NormalVerbosity) $ putLog "Database did not exist, doing full rebuild" 377 | return M.empty 378 | -- NB: we force the input ByteString because we really want the database file to be closed promptly 379 | Just bs -> length (BS.unpack bs) `seq` (Exception.evaluate (rnf db) >> return db) `Exception.catch` \(Exception.ErrorCall reason) -> do 380 | when (shakeVerbosity opts >= NormalVerbosity) $ putLog $ "Database unreadable (" ++ reason ++ "), doing full rebuild" 381 | return M.empty 382 | where db = runGetAll getPureDatabase bs 383 | 384 | when (shakeVerbosity opts >= ChattyVerbosity) $ putStr $ "Initial database:\n" ++ unlines [show fp ++ ": " ++ show status | (fp, status) <- M.toList db] 385 | db_mvar <- newMVar db 386 | 387 | wdb_mvar <- newMVar emptyWaitDatabase 388 | report_mvar <- emptyReportDatabase >>= newMVar 389 | 390 | -- Collect rules and wants, then execute the collected Act actions (in any order) 391 | let ((), complete_s) = runShake (SE { se_available_rules = [reverse (ss_rules complete_s)] }) (SS { ss_rules = [], ss_acts = [] }) mx 392 | 393 | -- You might think that we could lose the type signature here, and then inline mk_e into its sole use site. 394 | -- Unfortunately, that doesn't type check properly on GHC 7.0.1.20101215 (i.e. RC2), and I have no idea why. 395 | mk_e :: [[RuleClosure n]] -> ActEnv n 396 | mk_e act_rules = AE { ae_would_block_handles = [], ae_rules = act_rules, ae_database = db_mvar, ae_wait_database = wdb_mvar, ae_report = report_mvar, ae_pool = pool, ae_options = opts } 397 | 398 | run_acts :: forall m. (MonadLint m, LintNamespace m ~ n) => m () 399 | run_acts = void $ parallel pool $ flip map (ss_acts complete_s) $ \(act_rules, act) -> runActLinted [] (mk_e act_rules) act 400 | 401 | if shakeLint opts 402 | then do 403 | ss_mvar <- newEmptyMVar 404 | ss <- takeSnapshot 405 | (x, _) <- (flip State.runStateT ss . flip Reader.runReaderT ss_mvar) $ unLint' run_acts 406 | return x 407 | else unNoLint run_acts 408 | 409 | final_report <- takeMVar report_mvar 410 | traverse_ (\report_fp -> writeFile report_fp (produceReport final_report)) (shakeReport opts) 411 | 412 | final_db <- takeMVar db_mvar 413 | BS.writeFile ".openshake-db" (runPut $ putPureDatabase final_db) 414 | 415 | 416 | -- | Perform the specified action once we are done collecting rules in the 'Shake' monad. 417 | -- Just like 'want', there is no guarantee about the order in which the actions will be will be performed. 418 | act :: Act n () -> Shake n () 419 | act what = do 420 | rules <- asksShakeEnv se_available_rules 421 | modifyShakeState (\s -> s { ss_acts = (rules, what) : ss_acts s }) 422 | 423 | 424 | addRule :: Rule n -> Shake n () 425 | addRule rule = do 426 | rules <- asksShakeEnv se_available_rules 427 | modifyShakeState $ \s -> s { ss_rules = RC rules rule : ss_rules s } 428 | 429 | need :: Namespace n => [n] -> Act n [Entry n] 430 | need fps = do 431 | e <- askActEnv 432 | 433 | need_times <- Act $ Reader.ReaderT $ \_ -> State.StateT $ \s -> do 434 | mb_sss <- retakeSnapshot fps 435 | need_times <- need' e fps 436 | return (need_times, s { as_snapshots = maybe id (:) mb_sss (as_snapshots s) }) 437 | 438 | appendHistory $ Need (fps `zip` need_times) 439 | return need_times 440 | 441 | withoutMVar :: MonadPeelIO m => MVar a -> a -> m b -> m (a, b) 442 | withoutMVar mvar x act = do 443 | liftIO (putMVar mvar x) 444 | -- Suprisingly, it is important that we take from the MVar if there is an exception from act. 445 | -- The reason is that we might have something like this: 446 | -- modfiyMVar mvar $ \x -> withoutMVar mvar x $ throwIO e 447 | -- 448 | -- If we don't take from the MVar when we get the exception, modifyMVar will block because 449 | -- its onException handler tries to put into the (full) MVar. 450 | y <- act `Exception.onException` liftIO (takeMVar mvar) 451 | x' <- liftIO (takeMVar mvar) 452 | return (x', y) 453 | 454 | -- We assume that the rules do not change to include new dependencies often: this lets 455 | -- us not rerun a rule as long as it looks like the dependencies of the *last known run* 456 | -- of the rule have not changed 457 | doesQARequireRerun :: (Namespace n, Monad m) => ([n] -> m [Entry n]) -> QA n -> m (Maybe String) 458 | doesQARequireRerun need (Need nested_fps_times) = do 459 | let (nested_fps, nested_old_times) = unzip nested_fps_times 460 | -- NB: if this Need is for a generated file we have to build it again if any of the things *it* needs have changed, 461 | -- so we recursively invoke need in order to check if we have any changes 462 | nested_new_times <- need nested_fps 463 | return $ firstJust $ (\f -> zipWith3 f nested_fps nested_new_times nested_old_times) $ 464 | \fp old_time new_time -> guard (old_time /= new_time) >> return ("modification time of " ++ show fp ++ " has changed from " ++ show old_time ++ " to " ++ show new_time) 465 | 466 | 467 | class (Functor m, Monad m, MonadIO m, MonadPeelIO m) => MonadLint m where 468 | type LintNamespace m 469 | parallel :: Pool -> [m a] -> m [a] 470 | modifyMVarLint :: MVar a -> (a -> m (a, b)) -> m b 471 | retakeSnapshot :: [LintNamespace m] -> m (Maybe (Snapshot (LintNamespace m), Snapshot (LintNamespace m), [LintNamespace m])) 472 | liftBlockingIO :: IO a -> m a 473 | 474 | 475 | newtype NoLint n a = NoLint { unNoLint :: IO a } 476 | deriving (Functor, Monad, MonadIO, MonadPeelIO) 477 | 478 | instance MonadLint (NoLint n) where 479 | type LintNamespace (NoLint n) = n 480 | parallel pool = NoLint . Parallel.parallel pool . map unNoLint 481 | modifyMVarLint mvar f = NoLint $ modifyMVar mvar (unNoLint . f) 482 | retakeSnapshot _ = return Nothing 483 | liftBlockingIO = liftIO 484 | 485 | 486 | newtype Lint' n a = Lint' { unLint' :: Reader.ReaderT (MVar (Snapshot n)) (State.StateT (Snapshot n) IO) a } 487 | deriving (Functor, Monad, MonadIO, MonadPeelIO) 488 | 489 | lintIO :: ((Lint' n a -> IO a) -> IO b) -- ^ Supplies the IO action with a way to convert Lint actions into IO actions for the duration 490 | -> Lint' n b 491 | lintIO f = Lint' $ Reader.ReaderT $ \ss_mvar -> State.StateT $ \ss -> do 492 | -- Restore the most recent Snapshot to the MVar while running an outside action, in case 493 | -- that outside IO action schedules another Lint' action that will update the current Snapshot. 494 | putMVar ss_mvar ss 495 | res <- f $ \lint -> modifyMVar ss_mvar (\ss -> liftM swap (State.runStateT (Reader.runReaderT (unLint' lint) ss_mvar) ss)) 496 | -- If we scheduled another Lint action during that last call, the Snapshot will have changed. 497 | ss <- takeMVar ss_mvar 498 | return (res, ss) 499 | 500 | instance Namespace n => MonadLint (Lint' n) where 501 | type LintNamespace (Lint' n) = n 502 | -- My first thought was that if in non-linting mode, we could just run actions in parallel. If in linting mode, we could run them sequentially 503 | -- so we could validate the changes made at every step. 504 | -- 505 | -- Unfortunately, this isn't very cool because a rule might need something that is already being built by another branch above. E.g. I could 506 | -- need ["a", "b"], and the rule for ["a"] could need ["b"]. Now I'm screwed because the entry for "b" will be a WaitHandle, but waiting on it will 507 | -- deadlock. 508 | -- 509 | -- So I still need to keep around the mechanism of parallelism in lint mode, even though I only permit one thread to run at a time. 510 | parallel pool acts = lintIO $ \lint_to_io -> Parallel.parallel pool (map lint_to_io acts) 511 | 512 | modifyMVarLint mvar f = Lint' $ Reader.ReaderT $ \e -> State.StateT $ \s -> modifyMVar mvar (\x -> liftM (\((a, b), s) -> (a, (b, s))) $ State.runStateT (Reader.runReaderT (unLint' (f x)) e) s) 513 | 514 | retakeSnapshot fps = Lint' $ Reader.ReaderT $ \_e -> State.StateT $ \ss -> do 515 | -- Record data so we can lint the IO done in between entering a user rule and it invoking need 516 | ss' <- takeSnapshot 517 | -- Rule code tranisitioned from ss to ss' before needing fps 518 | return (Just (ss, ss', fps), ss') 519 | 520 | liftBlockingIO io = lintIO (const io) 521 | 522 | 523 | findAllRules :: (Namespace n, MonadLint m, LintNamespace m ~ n) 524 | => ActEnv n 525 | -> [n] -- ^ The files that we wish to find rules for 526 | -> [WaitHandle ()] -- ^ Handles that would be blocked if we blocked the thread right now 527 | -> PureDatabase n 528 | -> m (PureDatabase n, 529 | ([(n, m (Either ShakefileException (Entry n)))], -- Action that just waits for a build in progress elsewhere to complete 530 | [([n], m (Either ShakefileException [Entry n]))])) -- Action that creates (possibly several) of the files we asked for by invoking a user rule 531 | findAllRules _ [] _ db = return (db, ([], [])) 532 | findAllRules e (fp:fps) would_block_handles db = do 533 | (fps, would_block_handles, db, res_transformer) <- do 534 | let ei_unclean_clean = case M.lookup fp db of 535 | -- If the file is totally unknown to the database we're certainly going to have to build it 536 | Nothing -> Left Nothing 537 | -- Likewise if the file is known but we are the first to notice that the file is dirty, though in this case "building" it might just mean marking it as clean 538 | Just (Dirty hist mtime) -> Left (Just (hist, mtime)) 539 | -- We've previously discovered the file to be clean: return an action that just returns the computed entry directly 540 | Just (Clean _ mtime) -> Right $ return (Right mtime) 541 | -- Someone else is in the process of making the file clean. Return an action that wait on the wait handle for it to complete 542 | Just (Building _ wait_mvar) -> Right $ liftBlockingIO $ do 543 | -- We can avoid a lot of fuss if the wait handle is already triggered, so there can be no waiting. 544 | -- This is purely a performance optimisation: 545 | may_wait <- mayWaitOnWaitHandle wait_mvar 546 | let wrapper | may_wait = reportWorkerBlocked (ae_report e) . 547 | registerWait (ae_wait_database e) fp (fmap (const ()) wait_mvar) (ae_would_block_handles e) . 548 | Parallel.extraWorkerWhileBlocked (ae_pool e) -- NB: We must spawn a new pool worker while we wait, or we might get deadlocked by depleting the pool of workers 549 | | otherwise = id 550 | -- NB: we communicate the ModTimes of files that we were waiting on the completion of via the BuildingWaitHandle 551 | wrapper (waitOnWaitHandle wait_mvar) 552 | -- The file we depended on has completed building and it failed to do so: rethrow later. My guiding principle here is that 553 | -- this should behave the same as if building the file had been in progress when we got here, so delay the exception for a bit. 554 | Just (Failed sfe) -> Right $ return (Left sfe) -- TODO: common up with Clean? 555 | case ei_unclean_clean of 556 | Right clean_act -> return (fps, would_block_handles, db, second (first ((fp, clean_act) :))) 557 | Left mb_hist -> do 558 | -- 0) The artifact is *probably* going to be rebuilt, though we might still be able to skip a rebuild 559 | -- if a check of its history reveals that we don't need to. Get the rule we would use to do the rebuild. 560 | -- If this throws an exception, it is the fault of the **caller** of need so DON'T catch it 561 | (potential_creates_fps, potential_rule) <- liftIO $ findRule verbosity (ae_rules e) fp 562 | 563 | -- Cache the dirty status of each file the rule claims to create, just before we update the database. This information 564 | -- is used in the rule sanity checker later on. 565 | let non_dirty_fps = filter (\non_dirty_fp -> case M.lookup non_dirty_fp db of Nothing -> False; Just (Dirty _ _) -> False; _ -> True) potential_creates_fps 566 | 567 | -- NB: we have to find the rule and mark the things it may create as Building *before* we determine whether the 568 | -- file is actually dirty according to its history. This is because if the file *is* dirty according to that history 569 | -- then we want to prevent any recursive invocations of need from trying to Build some file that we have added a 570 | -- pending_unclean entry for already 571 | -- 572 | -- NB: people wanting *any* of the files created by this rule should wait on the same BuildingWaitHandle. 573 | -- However, we fmap each instance of it so that it only reports the Entry information for exactly the file you care about. 574 | (wait_handle, awake_waiters) <- liftIO newWaitHandle 575 | db <- return $ foldr (\(potential_creates_fp, extractor) db -> M.insert potential_creates_fp (Building mb_hist (fmap (liftM extractor) wait_handle)) db) db (potential_creates_fps `zip` listExtractors) 576 | 577 | -- If we block in recursive invocations of need' (if any), we will block the wait handle we just created from ever being triggered: 578 | would_block_handles <- return $ fmap (const ()) wait_handle : would_block_handles 579 | 580 | (db, ei_clean_hist_dirty_reason) <- case mb_hist of Nothing -> return (db, Right "file was not in the database") 581 | Just (hist, mtime) -> withoutMVar (ae_database e) db $ do 582 | mb_dirty_reason <- firstJustM $ map (doesQARequireRerun (need' (e { ae_would_block_handles = would_block_handles ++ ae_would_block_handles e }))) hist 583 | case mb_dirty_reason of 584 | Just dirty_reason -> return $ Right dirty_reason 585 | Nothing -> do 586 | -- The file wasn't dirty, but it might be "insane". For files, this occurs when the file 587 | -- has changed since we last looked at it even though its dependent files haven't changed. 588 | -- This usually indicates some sort of bad thing has happened (e.g. editing a generated file) -- 589 | -- we just rebuild it directly, though we could make another choice: 590 | mb_insane_reason <- liftIO $ sanityCheck fp mtime 591 | return $ maybe (Left (hist, mtime)) Right mb_insane_reason 592 | 593 | -- Each rule we execute will block the creation of some files if it waits: 594 | -- * It blocks the creation the files it *directly outputs* 595 | -- * It blocks the creation of those files that will be created *by the caller* (after we return) 596 | -- 597 | -- Note that any individual rule waiting *does not* block the creation of files built by other rules 598 | -- being run right. This is because everything gets executed in parallel. 599 | (creates_fps, basic_rule) <- case ei_clean_hist_dirty_reason of 600 | Left (clean_hist, clean_mtime) -> return ([fp], return (clean_hist, [clean_mtime])) -- NB: we checked that clean_mtime is still ok using sanityCheck above 601 | Right dirty_reason -> do 602 | -- Definitely dirty: NOW we sanity check the rule that we found earlier. 603 | let ei_why_rule_insane_unit = do 604 | -- a) Basic sanity check that the rule creates the file we actually need 605 | unless (fp `elem` potential_creates_fps) $ Left $ "A rule matched " ++ show fp ++ " but claims not to create it, only the files " ++ showStringList (map show potential_creates_fps) 606 | 607 | -- b) Make sure that none of the files that the proposed rule will create are not Dirty/unknown to the system. 608 | -- This is because it would be unsafe to run a rule creating a file that might be in concurrent 609 | -- use (read or write) by another builder process. 610 | -- 611 | -- It is VERY IMPORTANT that we delay doing this check until after we have checked the history to determine 612 | -- whether we need to rerun the rule. Here is the reason: 613 | -- 614 | -- Imagine that we had a rule that promised to rebuild the files [Foo.hi, Foo.o] from [Bar.hi]. Further imagine 615 | -- that someone else already needed [Foo.hi] and we had checked its history so that was marked as Clean in the database. 616 | -- 617 | -- Note that at this point [Foo.o] is still marked as dirty, [Foo.hi] is marked as clean, and the rule will promise 618 | -- to create both of them. If someone later needs [Foo.o] then if we do the sanity check eagerly things will look insane! 619 | -- What we want instead is to check the history of [Foo.o] *first* and hence detect that we don't need to run the rule. Then 620 | -- [Foo.o] will be marked as clean and all will be right with the world. 621 | unless (null non_dirty_fps) $ Left $ "A rule promised to yield the files " ++ showStringList (map show potential_creates_fps) ++ " in the process of building " ++ show fp ++ 622 | ", but the files " ++ showStringList (map show non_dirty_fps) ++ " have been independently built by someone else" 623 | 624 | -- Everything is OK! 625 | return () 626 | 627 | case ei_why_rule_insane_unit of 628 | -- If the rule is busted, create a "clean" action that actually just raises an error. By raising the error in the returned actions rather than right 629 | -- away we ensure that the exception gets reported as a problem in the files that we needed, rather than a problem in the guy doing the needing 630 | Left why_rule_insane -> return ([fp], Exception.throwIO sfe) 631 | where sfe = RuleError why_rule_insane 632 | Right () -> do 633 | when (verbosity >= ChattyVerbosity) $ putLog $ "Rebuild " ++ show fp ++ " because " ++ dirty_reason 634 | return (potential_creates_fps, potential_rule (\rules -> e { ae_rules = rules, ae_would_block_handles = fmap (const ()) wait_handle : ae_would_block_handles e })) 635 | 636 | let -- It is possible that we need two different files that are both created by the same rule. This is not an error! 637 | -- What we should do is remove from the remaning uncleans any files that are created by the rule we just added 638 | (next_fps_satisifed_here, fps') = partition (`elem` creates_fps) fps 639 | all_fps_satisfied_here = fp : next_fps_satisifed_here 640 | 641 | -- Augment the rule so that when it is run it sets all of the things it built to Clean again 642 | -- We also trim down the set of Entries it returns so that we only get entries for the *things 643 | -- we asked for*, not *the things the rule creates* 644 | rule = do 645 | -- Report any standard IO errors as ShakefileExceptions so we can delay them until the end 646 | -- At the same time, be careful not to wrap ShakefileExceptions from any nested needs. 647 | when (verbosity >= ChattyVerbosity) $ putLog $ "Running rule code to create " ++ showStringList (map show all_fps_satisfied_here) 648 | ei_sfe_result <- if shakeContinue (ae_options e) 649 | then fmap (either (\e -> Left (ActionError (e :: Exception.SomeException))) id) $ 650 | Exception.try (Exception.try basic_rule) 651 | else fmap Right basic_rule 652 | -- Everything else does not need to be monitored by the linter 653 | liftIO $ do 654 | let (ei_sfe_mtimes, creates_statuses) = case ei_sfe_result of 655 | -- Building the files succeeded, we should mark them as clean 656 | Right (nested_hist, mtimes) -> (Right mtimes, map (Clean nested_hist) mtimes) 657 | -- Building the files failed, so we need to mark it as such 658 | Left sfe -> (Left sfe, repeat (Failed sfe)) 659 | -- This is where we mark all of the files created by the rule as Clean/Failed: 660 | updateStatus (ae_database e) (creates_fps `zip` creates_statuses) 661 | -- Wake up all of the waiters on the old Building entry (if any) 662 | awake_waiters ei_sfe_mtimes 663 | -- Trim unnecessary modification times before we continue 664 | return $ fmap (\mtimes -> fromRight (\fp -> internalError $ "A pending unclean rule did not create the file " ++ show fp ++ " that we thought it did") $ lookupMany all_fps_satisfied_here (creates_fps `zip` mtimes)) ei_sfe_mtimes 665 | 666 | -- Display a helpful message to the user explaining the rules that we have decided upon: 667 | when (verbosity >= ChattyVerbosity) $ 668 | putLog $ "Using rule instance for " ++ showStringList (map show creates_fps) ++ " to create " ++ showStringList (map show creates_fps) ++ ", of which we actually needed " ++ showStringList (map show all_fps_satisfied_here) 669 | 670 | return (fps', would_block_handles, db, second (second ((all_fps_satisfied_here, rule) :))) 671 | fmap res_transformer $ findAllRules e fps would_block_handles db 672 | where 673 | verbosity = shakeVerbosity (ae_options e) 674 | 675 | need' :: (Namespace n, MonadLint m, LintNamespace m ~ n) => ActEnv n -> [n] -> m [Entry n] 676 | need' e init_fps = do 677 | -- Figure out the rules we need to use to create all the dirty files we need 678 | -- 679 | -- NB: this MVar operation does not block us because any thread only holds the database lock 680 | -- for a very short amount of time (and can only do IO stuff while holding it, not Act stuff). 681 | -- When we have to recursively invoke need, we put back into the MVar before doing so. 682 | (cleans, uncleans) <- modifyMVarLint (ae_database e) $ findAllRules e init_fps [] 683 | 684 | -- Run the rules we have decided upon in parallel 685 | -- 686 | -- NB: we report that the thread using parallel is blocked because it may go on to actually 687 | -- execute one of the parallel actions, which will bump the parallelism count without any 688 | -- extra parallelism actually occuring. 689 | unclean_times <- reportWorkerBlocked (ae_report e) $ parallel (ae_pool e) $ flip map uncleans $ \(unclean_fps, rule) -> reportWorkerRunning (ae_report e) $ liftM (fmapEither (map show unclean_fps,) (unclean_fps `zip`)) rule 690 | 691 | -- For things that are being built by someone else we only do trivial work, so don't have to spawn any thread 692 | clean_times <- forM cleans $ \(clean_fp, rule) -> liftM (fmapEither ([show clean_fp],) (\mtime -> [(clean_fp, mtime)])) rule 693 | 694 | -- Gather up any failures experienced in recursive needs, and the modtimes for files that were built succesfully 695 | let (failures, all_timess) = partitionEithers $ unclean_times ++ clean_times 696 | ([], reordered_times) = fromRight (\fp -> internalError $ "A call to need' didn't return a modification time for the input file " ++ show fp) $ lookupRemoveMany init_fps (concat all_timess) 697 | 698 | if null failures 699 | then return reordered_times 700 | else liftIO $ Exception.throwIO $ RecursiveError failures 701 | 702 | -- | Just a unique number to identify each update we make to the 'WaitDatabase' 703 | type WaitNumber = Int 704 | 705 | -- | A 'WaitHandle's that cannot be awoken because the thread that 706 | -- would do the awaking are blocked on another 'WaitHandle'. With each blocked 'WaitHandle' 707 | -- we record the reason that we did the blocking in the first place in the form of a 'String'. 708 | -- 709 | -- We record a 'WaitNumber' with each entry so that we can unregister a wait that we previously 710 | -- added without interfering with information that has been added in the interim. 711 | type BlockedWaitHandle n = (WaitNumber, n, WaitHandle ()) 712 | 713 | -- | Mapping from 'WaitHandle's being awaited upon to the 'WaitHandle's blocked 714 | -- from being awoken as a consequence of that waiting. 715 | data WaitDatabase n = WDB { 716 | wdb_next_waitno :: WaitNumber, 717 | wdb_waiters :: [(WaitHandle (), [BlockedWaitHandle n])] 718 | } 719 | 720 | emptyWaitDatabase :: WaitDatabase n 721 | emptyWaitDatabase = WDB { 722 | wdb_next_waitno = 0, 723 | wdb_waiters = [] 724 | } 725 | 726 | -- | This function is responsible for deadlock detection. 727 | -- 728 | -- The way the scheme works is that we have a global MVar containing a WaitDatabase. This database records 729 | -- all of the current waits in the application, along with: 730 | -- * The wait handles that cannot be triggered at the moment due to the outstanding wait (if any) 731 | -- * The reason that we are waiting at all 732 | -- 733 | -- Now, before we allow the actual wait to happen we check the database of outstanding waits. If we are in 734 | -- a situation where there is an outstanding wait on one of the handles that would become blocked by the pending 735 | -- wait, and we are waiting on a handle already blocked by that outstanding wait, then we have a deadlock. 736 | -- 737 | -- In this situation we throw an error instead of actually performing the wait, including in the error a descripton 738 | -- of the dependency chain that lead to the error reconstructed from the individual wait "why" information. 739 | registerWait :: forall n a. (Show n, Eq n) => MVar (WaitDatabase n) -> n -> WaitHandle () -> [WaitHandle ()] -> IO a -> IO a 740 | registerWait mvar_wdb new_why new_handle new_will_block_handles act = Exception.bracket register unregister (\_ -> act) 741 | where 742 | register = modifyMVar mvar_wdb register' 743 | register' (WDB new_waitno waiters) 744 | = case [why_chain | (why_chain, handle) <- transitive [([new_why], new_will_block_handle) | new_will_block_handle <- new_will_block_handles], new_handle == handle] of 745 | why_chain:_ -> shakefileError $ "Cyclic dependency detected through the chain " ++ showStringList (map show why_chain) 746 | [] -> return (wdb', new_waitno) 747 | where 748 | -- Update the database with the new waiters on this WaitHandle. We are careful to ensure that any 749 | -- existing waiters on the handle are preserved and put into the same entry in the association list. 750 | wdb' = WDB (new_waitno + 1) $ (new_handle, [ (new_waitno, new_why, new_will_block_handle) 751 | | new_will_block_handle <- new_will_block_handles ] ++ 752 | find_blocked_wait_handles new_handle) : 753 | filter ((/= new_handle) . fst) waiters 754 | 755 | find_blocked_wait_handles :: WaitHandle () -> [BlockedWaitHandle n] 756 | find_blocked_wait_handles wait_handle = fromMaybe [] (wait_handle `lookup` waiters) 757 | 758 | -- When we compute whether we are blocked, we need to do a transitive closure. This is necessary for situations where 759 | -- e.g. A.o -> B.o -> C.o, because we need to see that A.o is waiting on C.o's WaitHandle through B.o's WaitHandle. 760 | transitive :: [([n], WaitHandle ())] -> [([n], WaitHandle ())] 761 | transitive init_blocked = flip fixEq init_blocked $ \blocked -> nub $ blocked ++ [ (why : why_chain, next_blocked_handle) 762 | | (why_chain, blocked_handle) <- blocked 763 | , (_waitno, why, next_blocked_handle) <- find_blocked_wait_handles blocked_handle ] 764 | 765 | -- When we have completed the wait, remove all information about it from the wait database. 766 | -- Since we inserted it all with a unique integer, this is rather easy to do. To prevent the 767 | -- database growing unnecessarily, we carefully remove any wdb_waiters entries that don't block 768 | -- any handles at all after the removal. 769 | unregister unreg_waitno = modifyMVar_ mvar_wdb (Exception.evaluate . unregister' unreg_waitno) 770 | unregister' unreg_waitno wdb 771 | = wdb { wdb_waiters = [(waiting_on, blocked') | (waiting_on, blocked) <- wdb_waiters wdb 772 | , let blocked' = filter (\(waitno, _, _) -> unreg_waitno /= waitno) blocked 773 | , not (null blocked')] } 774 | 775 | 776 | data ReportDatabase = RDB { 777 | rdb_observed_commands :: [(String, NominalDiffTime)], 778 | rdb_observed_concurrency :: [(UTCTime, Int)], 779 | rdb_concurrency :: Int, 780 | rdb_start_at :: UTCTime 781 | } 782 | 783 | emptyReportDatabase :: IO ReportDatabase 784 | emptyReportDatabase = do 785 | ts <- getCurrentTime 786 | return $ RDB { 787 | rdb_observed_commands = [], 788 | rdb_observed_concurrency = [(ts, 1)], 789 | rdb_concurrency = 1, 790 | rdb_start_at = ts 791 | } 792 | 793 | reportWorkerBlocked, reportWorkerRunning :: MonadPeelIO m => MVar ReportDatabase -> m a -> m a 794 | reportWorkerBlocked = reportConcurrencyBump (-1) 795 | reportWorkerRunning = reportConcurrencyBump 1 796 | 797 | reportConcurrencyBump :: MonadPeelIO m => Int -> MVar ReportDatabase -> m a -> m a 798 | reportConcurrencyBump bump mvar_rdb act = Exception.bracket (liftIO $ bump_concurrency bump) (\() -> liftIO $ bump_concurrency (negate bump)) (\() -> act) 799 | where bump_concurrency directed_bump = modifyMVar_ mvar_rdb $ \rdb -> getCurrentTime >>= \ts -> return $ rdb { rdb_concurrency = rdb_concurrency rdb + directed_bump, rdb_observed_concurrency = (ts, rdb_concurrency rdb - directed_bump) : rdb_observed_concurrency rdb } 800 | 801 | reportCommand :: String -> IO a -> Act n a 802 | reportCommand cmd act = do 803 | mvar_rdb <- fmap ae_report askActEnv 804 | liftIO $ reportCommandIO mvar_rdb cmd act 805 | 806 | reportCommandIO :: MVar ReportDatabase -> String -> IO a -> IO a 807 | reportCommandIO mvar_rdb cmd act = do 808 | start_ts <- getCurrentTime 809 | res <- act 810 | end_ts <- getCurrentTime 811 | 812 | modifyMVar_ mvar_rdb $ \rdb -> return $ rdb { rdb_observed_commands = (cmd, end_ts `diffUTCTime` start_ts) : rdb_observed_commands rdb } 813 | return res 814 | 815 | produceReport :: ReportDatabase -> String 816 | produceReport rdb = "OpenShake report" ++ 817 | "

Parallelism over time

" ++ parallelism ++ 818 | "

Long-running commands

" ++ long_running_commands ++ "
CommandTime
" ++ 819 | "" 820 | where 821 | -- TODO: encode string suitably for enclosing in quotes in attribute 822 | attributeEncode = id 823 | -- TODO: encode string suitably for using as text in HTML 824 | htmlEncode = id 825 | 826 | parallelism = "" 827 | -- NB: concurrency sometimes becomes negative for very small periods of time. We should probably filter these out, but 828 | -- for now I'll just make them to 0. It is essential that we don't let values like -1 get into the chart data sent to 829 | -- Google, because Charts interprets a y-range minimum of -1 as "no minimum"... 830 | concurrency_xy = [ (realToFrac (time `diffUTCTime` rdb_start_at rdb) :: Double, 0 `max` concurrency) 831 | | (time, concurrency) <- reverse $ rdb_observed_concurrency rdb] 832 | 833 | long_running_commands = unlines ["" ++ htmlEncode cmd ++ "" ++ htmlEncode (show runtime) ++ "" | (cmd, runtime) <- command_data] 834 | command_data = take 50 $ reverse $ sortBy (comparing snd) $ rdb_observed_commands rdb 835 | 836 | -- See , 837 | concurrencyChartURL :: (Int, Int) -> [(Double, Int)] -> String 838 | concurrencyChartURL (width, height) xys 839 | = "http://chart.apis.google.com/chart?cht=lxy&chd=t:" ++ encode_series xs ++ "|" ++ encode_series ys ++ 840 | "&chds=" ++ range xs ++ "," ++ range ys ++ -- Setup data range for the text encoding 841 | "&chxt=x,y&chxr=0," ++ range xs ++ "|1," ++ range (0:ys) ++ -- Setup axis range (we force the y axis to start at 0 even if minimum parallelism was 1) 842 | "&chco=3674FB" ++ -- Color of line 843 | "&chm=B,76A4FB,0,0,0" ++ -- Color underneath the drawn line 844 | "&chs=" ++ show width ++ "x" ++ show height -- Image size 845 | where (xs, ys) = unzip xys 846 | 847 | encode_series :: Show a => [a] -> String 848 | encode_series = intercalate "," . map show 849 | 850 | range :: (Ord a, Show a) => [a] -> String 851 | range zs = show (minimum zs) ++ "," ++ show (maximum zs) 852 | 853 | 854 | updateStatus :: Namespace n => Database n -> [(n, Status n)] -> IO () 855 | updateStatus db_mvar fp_statuses = modifyMVar_ db_mvar (return . go) 856 | where go init_db = foldr (\(fp, status) db -> M.insert fp status db) init_db fp_statuses 857 | 858 | 859 | appendHistory :: QA n -> Act n () 860 | appendHistory extra_qa = modifyActState $ \s -> s { as_this_history = as_this_history s ++ [extra_qa] } 861 | 862 | findRule :: (Namespace n, MonadLint m, LintNamespace m ~ n) 863 | => Verbosity -> [[RuleClosure n]] -> n 864 | -> IO ([n], ([[RuleClosure n]] -> ActEnv n) -> m (History n, [Entry n])) 865 | findRule verbosity ruless fp = do 866 | possibilities <- flip mapMaybeM ruless $ \rules -> do 867 | generators <- mapMaybeM (\rc -> liftM (fmap ((,) (rc_closure rc))) $ rc_rule rc fp) rules 868 | return (guard (not (null generators)) >> Just generators) 869 | (clo_rules, (creates_fps, action)) <- case possibilities of 870 | (generator:other_matches):_next_level -> do 871 | unless (null other_matches) $ 872 | when (verbosity > NormalVerbosity) $ 873 | putLog $ "Ambiguous rules for " ++ show fp ++ ": choosing the first one" 874 | return generator 875 | [] -> do 876 | mb_generator <- defaultRule fp 877 | case mb_generator of 878 | Nothing -> shakefileError $ "No rule to build " ++ show fp 879 | Just generator -> return $ ([], generator) -- TODO: generalise to allow default rules to refer to others? 880 | 881 | return (creates_fps, \mk_e -> runActLinted creates_fps (mk_e clo_rules) action) 882 | 883 | runActLinted :: (Namespace n, MonadLint m, LintNamespace m ~ n) => [n] -> ActEnv n -> Act n a -> m (History n, a) 884 | runActLinted creates_fps e action = do 885 | (res, final_nested_s) <- runAct e (AS { as_this_history = [], as_snapshots = [] }) action 886 | -- User code transitioned from ss to ss' before returning without needing anything else 887 | mb_sss <- retakeSnapshot [] 888 | -- FIXME: accumulate errors rather than showing them eagerly like this 889 | liftIO $ mapM_ (hPutStrLn stderr) $ lintSnapshots creates_fps (reverse $ maybe id (:) mb_sss (as_snapshots final_nested_s)) 890 | return (as_this_history final_nested_s, res) 891 | --------------------------------------------------------------------------------