module Development.Shake.Core(
run,
ShakeValue,
Rule(..), Rules, rule, action, withoutActions, alternatives, priority,
Action, actionOnException, actionFinally, apply, apply1, traced, getShakeOptions, getProgress,
trackUse, trackChange, trackAllow,
getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,
Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,
newCache, newCacheIO,
unsafeExtraThread, unsafeAllowApply,
parallel,
orderOnlyAction,
runAfter
) where
import Control.Exception.Extra
import Control.Applicative
import Data.Tuple.Extra
import Control.Concurrent.Extra
import Control.Monad.Extra
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Writer.Strict
import Data.Typeable
import Data.Function
import Data.Either.Extra
import Numeric.Extra
import Data.List.Extra
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Data.IORef
import System.Directory
import System.IO.Extra
import System.Time.Extra
import Data.Monoid
import System.IO.Unsafe
import Development.Shake.Classes
import Development.Shake.Pool
import Development.Shake.Database
import Development.Shake.Monad
import Development.Shake.Resource
import Development.Shake.Value
import Development.Shake.Profile
import Development.Shake.Types
import Development.Shake.Errors
import Development.Shake.Special
import General.Timing
import General.Extra
import General.Concurrent
import General.Cleanup
import General.String
import Prelude
class (ShakeValue key, ShakeValue value) => Rule key value where
storedValue :: ShakeOptions -> key -> IO (Maybe value)
equalValue :: ShakeOptions -> key -> value -> value -> EqualCost
equalValue _ _ v1 v2 = if v1 == v2 then EqualCheap else NotEqual
data ARule m = forall key value . Rule key value => ARule (key -> Maybe (m value))
ruleKey :: (key -> Maybe (m value)) -> key
ruleKey = err "ruleKey"
ruleValue :: (key -> Maybe (m value)) -> value
ruleValue = err "ruleValue"
newtype Rules a = Rules (WriterT (SRules Action) IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
newRules :: SRules Action -> Rules ()
newRules = Rules . tell
modifyRules :: (SRules Action -> SRules Action) -> Rules () -> Rules ()
modifyRules f (Rules r) = Rules $ censor f r
getRules :: Rules () -> IO (SRules Action)
getRules (Rules r) = execWriterT r
data SRules m = SRules
{actions :: [m ()]
,rules :: Map.HashMap TypeRep (TypeRep,TypeRep,[(Double,ARule m)])
}
instance Monoid (SRules m) where
mempty = SRules [] (Map.fromList [])
mappend (SRules x1 x2) (SRules y1 y2) = SRules (x1++y1) (Map.unionWith f x2 y2)
where f (k, v1, xs) (_, v2, ys)
| v1 == v2 = (k, v1, xs ++ ys)
| otherwise = unsafePerformIO $ errorIncompatibleRules k v1 v2
instance Monoid a => Monoid (Rules a) where
mempty = return mempty
mappend = liftA2 mappend
rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()
rule r = newRules mempty{rules = Map.singleton k (k, v, [(1,ARule r)])}
where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r
priority :: Double -> Rules () -> Rules ()
priority i = modifyRules $ \s -> s{rules = Map.map (\(a,b,cs) -> (a,b,map (first $ const i) cs)) $ rules s}
alternatives :: Rules () -> Rules ()
alternatives = modifyRules $ \r -> r{rules = Map.map f $ rules r}
where
f (k, v, []) = (k, v, [])
f (k, v, xs) = let (is,rs) = unzip xs in (k, v, [(maximum is, foldl1' g rs)])
g (ARule a) (ARule b) = ARule $ \x -> a x `mplus` b2 x
where b2 = fmap (fmap (fromJust . cast)) . b . fromJust . cast
action :: Action a -> Rules ()
action a = newRules mempty{actions=[void a]}
withoutActions :: Rules () -> Rules ()
withoutActions = modifyRules $ \x -> x{actions=[]}
registerWitnesses :: SRules m -> IO ()
registerWitnesses SRules{..} =
forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do
registerWitness $ ruleKey r
registerWitness $ ruleValue r
data RuleInfo m = RuleInfo
{stored :: Key -> IO (Maybe Value)
,equal :: Key -> Value -> Value -> EqualCost
,execute :: Key -> m Value
,resultType :: TypeRep
}
createRuleinfo :: ShakeOptions -> SRules Action -> Map.HashMap TypeRep (RuleInfo Action)
createRuleinfo opt SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (equal rs) (execute rs) tv
where
stored ((_,ARule r):_) = fmap (fmap newValue) . f r . fromKey
where f :: Rule key value => (key -> Maybe (m value)) -> (key -> IO (Maybe value))
f _ = storedValue opt
equal ((_,ARule r):_) = \k v1 v2 -> f r (fromKey k) (fromValue v1) (fromValue v2)
where f :: Rule key value => (key -> Maybe (m value)) -> key -> value -> value -> EqualCost
f _ = equalValue opt
execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of
[r]:_ -> r
rs -> liftIO $ errorMultipleRulesMatch (typeKey k) (show k) (length rs)
where rs2 = sets [(i, \k -> fmap newValue <$> r (fromKey k)) | (i,ARule r) <- rs]
sets :: Ord a => [(a, b)] -> [[b]]
sets = map snd . reverse . groupSort
runStored :: Map.HashMap TypeRep (RuleInfo m) -> Key -> IO (Maybe Value)
runStored mp k = case Map.lookup (typeKey k) mp of
Nothing -> return Nothing
Just RuleInfo{..} -> stored k
runEqual :: Map.HashMap TypeRep (RuleInfo m) -> Key -> Value -> Value -> EqualCost
runEqual mp k v1 v2 = case Map.lookup (typeKey k) mp of
Nothing -> NotEqual
Just RuleInfo{..} -> equal k v1 v2
runExecute :: MonadIO m => Map.HashMap TypeRep (RuleInfo m) -> Key -> m Value
runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of
Nothing -> liftIO $ errorNoRuleToBuildType tk (Just $ show k) Nothing
Just RuleInfo{..} -> execute k
data Global = Global
{globalDatabase :: Database
,globalPool :: Pool
,globalCleanup :: Cleanup
,globalTimestamp :: IO Seconds
,globalRules :: Map.HashMap TypeRep (RuleInfo Action)
,globalOutput :: Verbosity -> String -> IO ()
,globalOptions :: ShakeOptions
,globalDiagnostic :: String -> IO ()
,globalLint :: String -> IO ()
,globalAfter :: IORef [IO ()]
,globalTrackAbsent :: IORef [(Key, Key)]
,globalProgress :: IO Progress
}
data Local = Local
{localStack :: Stack
,localVerbosity :: Verbosity
,localBlockApply :: Maybe String
,localDepends :: [Depends]
,localDiscount :: !Seconds
,localTraces :: [Trace]
,localTrackAllows :: [Key -> Bool]
,localTrackUsed :: [Key]
}
newtype Action a = Action {fromAction :: RAW Global Local a}
deriving (Functor, Applicative, Monad, MonadIO)
actionBoom :: Bool -> Action a -> IO b -> Action a
actionBoom runOnSuccess act clean = do
cleanup <- Action $ getsRO globalCleanup
clean <- liftIO $ addCleanup cleanup $ void clean
res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (clean True) >> throwRAW e
liftIO $ clean runOnSuccess
return res
actionOnException :: Action a -> IO b -> Action a
actionOnException = actionBoom False
actionFinally :: Action a -> IO b -> Action a
actionFinally = actionBoom True
run :: ShakeOptions -> Rules () -> IO ()
run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do
opts@ShakeOptions{..} <- if shakeThreads /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p}
start <- offsetTime
rs <- getRules rs
registerWitnesses rs
outputLocked <- do
lock <- newLock
return $ \v msg -> withLock lock $ shakeOutput v msg
let diagnostic = if shakeVerbosity >= Diagnostic then outputLocked Diagnostic . ("% "++) else const $ return ()
let output v = outputLocked v . abbreviate shakeAbbreviations
diagnostic "Starting run"
except <- newIORef (Nothing :: Maybe (String, ShakeException))
let raiseError err
| not shakeStaunch = throwIO err
| otherwise = do
let named = abbreviate shakeAbbreviations . shakeExceptionTarget
atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())
lint <- if isNothing shakeLint then return $ const $ return () else do
dir <- getCurrentDirectory
return $ \msg -> do
now <- getCurrentDirectory
when (dir /= now) $ errorStructured
"Lint checking error - current directory has changed"
[("When", Just msg)
,("Wanted",Just dir)
,("Got",Just now)]
""
diagnostic "Starting run 2"
after <- newIORef []
absent <- newIORef []
withCleanup $ \cleanup -> do
_ <- addCleanup cleanup $ do
when shakeTimings printTimings
resetTimings
withNumCapabilities shakeThreads $ do
diagnostic "Starting run 3"
withDatabase opts diagnostic $ \database -> do
wait <- newBarrier
let getProgress = do
failure <- fmap fst <$> readIORef except
stats <- progress database
return stats{isFailure=failure}
tid <- flip forkFinally (const $ signalBarrier wait ()) $
shakeProgress getProgress
_ <- addCleanup cleanup $ do
killThread tid
void $ timeout 1000000 $ waitBarrier wait
let ruleinfo = createRuleinfo opts rs
addTiming "Running rules"
runPool (shakeThreads == 1) shakeThreads $ \pool -> do
let s0 = Global database pool cleanup start ruleinfo output opts diagnostic lint after absent getProgress
let s1 = Local emptyStack shakeVerbosity Nothing [] 0 [] [] []
forM_ (actions rs) $ \act ->
addPool pool $ runAction s0 s1 act $ \x -> case x of
Left e -> raiseError =<< shakeException s0 (return ["Top-level action/want"]) e
Right x -> return x
maybe (return ()) (throwIO . snd) =<< readIORef except
assertFinishedDatabase database
when (null $ actions rs) $
when (shakeVerbosity >= Normal) $ output Normal "Warning: No want/action statements, nothing to do"
when (isJust shakeLint) $ do
addTiming "Lint checking"
absent <- readIORef absent
checkValid database (runStored ruleinfo) (runEqual ruleinfo) absent
when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"
when (shakeReport /= []) $ do
addTiming "Profile report"
report <- toReport database
forM_ shakeReport $ \file -> do
when (shakeVerbosity >= Normal) $
output Normal $ "Writing report to " ++ file
writeProfile file report
when (shakeLiveFiles /= []) $ do
addTiming "Listing live"
live <- listLive database
let liveFiles = [show k | k <- live, specialIsFileKey $ typeKey k]
forM_ shakeLiveFiles $ \file -> do
when (shakeVerbosity >= Normal) $
output Normal $ "Writing live list to " ++ file
(if file == "-" then putStr else writeFile file) $ unlines liveFiles
sequence_ . reverse =<< readIORef after
lineBuffering :: IO a -> IO a
lineBuffering = withBuffering stdout LineBuffering . withBuffering stderr LineBuffering
abbreviate :: [(String,String)] -> String -> String
abbreviate [] = id
abbreviate abbrev = f
where
ordAbbrev = sortOn (negate . length . fst) abbrev
f [] = []
f x | (to,rest):_ <- [(to,rest) | (from,to) <- ordAbbrev, Just rest <- [stripPrefix from x]] = to ++ f rest
f (x:xs) = x : f xs
runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)
runAction g l (Action x) = runRAW g l x
runAfter :: IO () -> Action ()
runAfter op = do
Global{..} <- Action getRO
liftIO $ atomicModifyIORef globalAfter $ \ops -> (op:ops, ())
apply :: Rule key value => [key] -> Action [value]
apply = applyForall
applyForall :: forall key value . Rule key value => [key] -> Action [value]
applyForall ks = do
let tk = typeOf (err "apply key" :: key)
tv = typeOf (err "apply type" :: value)
Global{..} <- Action getRO
block <- Action $ getsRW localBlockApply
whenJust block $ liftIO . errorNoApply tk (show <$> listToMaybe ks)
case Map.lookup tk globalRules of
Nothing -> liftIO $ errorNoRuleToBuildType tk (show <$> listToMaybe ks) (Just tv)
Just RuleInfo{resultType=tv2} | tv /= tv2 -> liftIO $ errorRuleTypeMismatch tk (show <$> listToMaybe ks) tv2 tv
_ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks
applyKeyValue :: [Key] -> Action [Value]
applyKeyValue [] = return []
applyKeyValue ks = do
global@Global{..} <- Action getRO
let exec stack k continue = do
let s = Local {localVerbosity=shakeVerbosity globalOptions, localDepends=[], localStack=stack, localBlockApply=Nothing
,localDiscount=0, localTraces=[], localTrackAllows=[], localTrackUsed=[]}
let top = showTopStack stack
time <- offsetTime
runAction global s (do
liftIO $ evaluate $ rnf k
liftIO $ globalLint $ "before building " ++ top
putWhen Chatty $ "# " ++ show k
res <- runExecute globalRules k
when (Just LintFSATrace == shakeLint globalOptions) trackCheckUsed
Action $ fmap ((,) res) getRW) $ \x -> case x of
Left e -> continue . Left . toException =<< shakeException global (showStack globalDatabase stack) e
Right (res, Local{..}) -> do
dur <- time
globalLint $ "after building " ++ top
let ans = (res, reverse localDepends, dur localDiscount, reverse localTraces)
evaluate $ rnf ans
continue $ Right ans
stack <- Action $ getsRW localStack
(dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (Ops (runStored globalRules) (runEqual globalRules) exec) stack ks
Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}
return vs
shakeException :: Global -> IO [String] -> SomeException -> IO ShakeException
shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of
Just e@ShakeException{} -> return e
Nothing -> do
stk <- stk
e <- return $ ShakeException (last $ "Unknown call stack" : stk) stk e
when (shakeStaunch && shakeVerbosity >= Quiet) $
globalOutput Quiet $ show e ++ "Continuing due to staunch mode"
return e
apply1 :: Rule key value => key -> Action value
apply1 = fmap head . apply . return
getShakeOptions :: Action ShakeOptions
getShakeOptions = Action $ getsRO globalOptions
getProgress :: Action Progress
getProgress = do
res <- Action $ getsRO globalProgress
liftIO res
traced :: String -> IO a -> Action a
traced msg act = do
Global{..} <- Action getRO
stack <- Action $ getsRW localStack
start <- liftIO globalTimestamp
putNormal $ "# " ++ msg ++ " (for " ++ showTopStack stack ++ ")"
res <- liftIO act
stop <- liftIO globalTimestamp
Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) (doubleToFloat start) (doubleToFloat stop) : localTraces s}
return res
putWhen :: Verbosity -> String -> Action ()
putWhen v msg = do
Global{..} <- Action getRO
verb <- getVerbosity
when (verb >= v) $
liftIO $ globalOutput v msg
putLoud :: String -> Action ()
putLoud = putWhen Loud
putNormal :: String -> Action ()
putNormal = putWhen Normal
putQuiet :: String -> Action ()
putQuiet = putWhen Quiet
getVerbosity :: Action Verbosity
getVerbosity = Action $ getsRW localVerbosity
withVerbosity :: Verbosity -> Action a -> Action a
withVerbosity new = Action . unmodifyRW f . fromAction
where f s0 = (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0})
quietly :: Action a -> Action a
quietly = withVerbosity Quiet
trackUse :: ShakeValue key => key -> Action ()
trackUse key = do
let k = newKey key
Global{..} <- Action getRO
l@Local{..} <- Action getRW
deps <- liftIO $ concatMapM (listDepends globalDatabase) localDepends
let top = topStack localStack
if top == Just k then
return ()
else if k `elem` deps then
return ()
else if any ($ k) localTrackAllows then
return ()
else
Action $ putRW l{localTrackUsed = k : localTrackUsed}
trackCheckUsed :: Action ()
trackCheckUsed = do
Global{..} <- Action getRO
Local{..} <- Action getRW
liftIO $ do
deps <- concatMapM (listDepends globalDatabase) localDepends
bad <- return $ localTrackUsed \\ deps
unless (null bad) $ do
let n = length bad
errorStructured
("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")
[("Used", Just $ show x) | x <- bad]
""
bad <- flip filterM localTrackUsed $ \k -> (not . null) <$> lookupDependencies globalDatabase k
unless (null bad) $ do
let n = length bad
errorStructured
("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")
[("Used", Just $ show x) | x <- bad]
""
trackChange :: ShakeValue key => key -> Action ()
trackChange key = do
let k = newKey key
Global{..} <- Action getRO
Local{..} <- Action getRW
liftIO $ do
let top = topStack localStack
if top == Just k then
return ()
else if any ($ k) localTrackAllows then
return ()
else
atomicModifyIORef globalTrackAbsent $ \ks -> ((fromMaybe k top, k):ks, ())
trackAllow :: ShakeValue key => (key -> Bool) -> Action ()
trackAllow = trackAllowForall
trackAllowForall :: forall key . ShakeValue key => (key -> Bool) -> Action ()
trackAllowForall test = Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s}
where
tk = typeOf (err "trackAllow key" :: key)
f k = typeKey k == tk && test (fromKey k)
newResource :: String -> Int -> Rules Resource
newResource name mx = liftIO $ newResourceIO name mx
newThrottle :: String -> Int -> Double -> Rules Resource
newThrottle name count period = liftIO $ newThrottleIO name count period
unsafeAllowApply :: Action a -> Action a
unsafeAllowApply = applyBlockedBy Nothing
blockApply :: String -> Action a -> Action a
blockApply = applyBlockedBy . Just
applyBlockedBy :: Maybe String -> Action a -> Action a
applyBlockedBy reason = Action . unmodifyRW f . fromAction
where f s0 = (s0{localBlockApply=reason}, \s -> s{localBlockApply=localBlockApply s0})
withResource :: Resource -> Int -> Action a -> Action a
withResource r i act = do
Global{..} <- Action getRO
liftIO $ globalDiagnostic $ show r ++ " waiting to acquire " ++ show i
offset <- liftIO offsetTime
Action $ captureRAW $ \continue -> acquireResource r globalPool i $ continue $ Right ()
res <- Action $ tryRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) $ do
offset <- liftIO offset
liftIO $ globalDiagnostic $ show r ++ " acquired " ++ show i ++ " in " ++ showDuration offset
Action $ modifyRW $ \s -> s{localDiscount = localDiscount s + offset}
act
liftIO $ releaseResource r globalPool i
liftIO $ globalDiagnostic $ show r ++ " released " ++ show i
Action $ either throwRAW return res
withResources :: [(Resource, Int)] -> Action a -> Action a
withResources res act
| (r,i):_ <- filter ((< 0) . snd) res = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show i
| otherwise = f $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) res
where
f [] = act
f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs
newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v)
newCacheIO act = do
var <- newVar Map.empty
return $ \key ->
join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of
Just bar -> return $ (,) mp $ do
res <- liftIO $ testFence bar
(res,offset) <- case res of
Just res -> return (res, 0)
Nothing -> do
pool <- Action $ getsRO globalPool
offset <- liftIO offsetTime
Action $ captureRAW $ \k -> waitFence bar $ \v ->
addPool pool $ do offset <- liftIO offset; k $ Right (v,offset)
case res of
Left err -> Action $ throwRAW err
Right (deps,v) -> do
Action $ modifyRW $ \s -> s{localDepends = deps ++ localDepends s, localDiscount = localDiscount s + offset}
return v
Nothing -> do
bar <- newFence
return $ (,) (Map.insert key bar mp) $ do
pre <- Action $ getsRW localDepends
res <- Action $ tryRAW $ fromAction $ act key
case res of
Left err -> do
liftIO $ signalFence bar $ Left err
Action $ throwRAW err
Right v -> do
post <- Action $ getsRW localDepends
let deps = take (length post length pre) post
liftIO $ signalFence bar $ Right (deps, v)
return v
newCache :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)
newCache = liftIO . newCacheIO
unsafeExtraThread :: Action a -> Action a
unsafeExtraThread act = Action $ do
Global{..} <- getRO
stop <- liftIO $ increasePool globalPool
res <- tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act
liftIO stop
captureRAW $ \continue -> (if isLeft res then addPoolPriority else addPool) globalPool $ continue res
parallel :: [Action a] -> Action [a]
parallel [] = return []
parallel [x] = fmap return x
parallel acts = Action $ do
global@Global{..} <- getRO
local <- getRW
todo :: Var (Maybe Int) <- liftIO $ newVar $ Just $ length acts
results :: [IORef (Maybe (Either SomeException a))] <- liftIO $ replicateM (length acts) $ newIORef Nothing
captureRAW $ \continue -> do
let resume = do
res <- liftIO $ sequence . catMaybes <$> mapM readIORef results
continue res
liftIO $ forM_ (zip acts results) $ \(act, result) -> do
let act2 = ifM (liftIO $ isJust <$> readVar todo) act (fail "")
addPool globalPool $ runAction global local act2 $ \res -> do
writeIORef result $ Just res
modifyVar_ todo $ \v -> case v of
Nothing -> return Nothing
Just i | i == 1 || isLeft res -> do resume; return Nothing
Just i -> return $ Just $ i 1
orderOnlyAction :: Action a -> Action a
orderOnlyAction act = Action $ do
pre <- getsRW localDepends
res <- fromAction act
modifyRW $ \s -> s{localDepends=pre}
return res