#if __GLASGOW_HASKELL__ >= 704
#endif
module Development.Shake.Core(
run,
#if __GLASGOW_HASKELL__ >= 704
ShakeValue,
#endif
Rule(..), Rules, defaultRule, rule, action, withoutActions, alternatives,
Action, actionOnException, actionFinally, apply, apply1, traced, getShakeOptions,
trackUse, trackChange, trackAllow,
getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,
Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,
newCache, newCacheIO,
unsafeExtraThread,
rulesIO, runAfter
) where
import Control.Exception as E
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Writer.Strict
import Data.Typeable
import Data.Function
import Data.List
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.IORef
import System.Directory
import System.IO
import Development.Shake.Classes
import Development.Shake.Pool
import Development.Shake.Database
import Development.Shake.Resource
import Development.Shake.Value
import Development.Shake.Report
import Development.Shake.Types
import Development.Shake.Errors
import General.Timing
import General.Base
import General.String
import General.RAW
#if __GLASGOW_HASKELL__ >= 704
type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a)
#endif
class (
#if __GLASGOW_HASKELL__ >= 704
ShakeValue key, ShakeValue value
#else
Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key,
Show value, Typeable value, Eq value, Hashable value, Binary value, NFData value
#endif
) => Rule key value where
storedValue :: ShakeOptions -> key -> IO (Maybe value)
data ARule m = forall key value . Rule key value => ARule (key -> Maybe (m value))
ruleKey :: Rule key value => (key -> Maybe (m value)) -> key
ruleKey = err "ruleKey"
ruleValue :: Rule key value => (key -> Maybe (m value)) -> value
ruleValue = err "ruleValue"
newtype Rules a = Rules (WriterT (SRules Action) IO a)
deriving (Monad, Functor, Applicative)
rulesIO :: IO a -> Rules a
rulesIO = Rules . liftIO
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,[(Int,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 = errorIncompatibleRules k v1 v2
instance Monoid a => Monoid (Rules a) where
mempty = return mempty
mappend = liftA2 mappend
defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()
defaultRule = rulePriority 0
rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()
rule = rulePriority 1
rulePriority :: Rule key value => Int -> (key -> Maybe (Action value)) -> Rules ()
rulePriority i r = newRules mempty{rules = Map.singleton k (k, v, [(i,ARule r)])}
where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r
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=[a >> return ()]}
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)
,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) (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
execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of
[r]:_ -> r
rs -> errorMultipleRulesMatch (typeKey k) (show k) (length rs)
where rs2 = sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs]
sets :: Ord a => [(a, b)] -> [[b]]
sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
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
runExecute :: Map.HashMap TypeRep (RuleInfo m) -> Key -> m Value
runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of
Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing
Just RuleInfo{..} -> execute k
data Global = Global
{globalDatabase :: Database
,globalPool :: Pool
,globalTimestamp :: IO Time
,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)]
}
data Local = Local
{localStack :: Stack
,localVerbosity :: Verbosity
,localBlockApply :: Maybe String
,localDepends :: [Depends]
,localDiscount :: !Duration
,localTraces :: [Trace]
,localTrackAllows :: [Key -> Bool]
,localTrackUsed :: [Key]
}
newtype Action a = Action {fromAction :: RAW Global Local a}
deriving (Functor, Applicative, Monad, MonadIO)
actionOnException :: Action a -> IO b -> Action a
actionOnException act clean = Action $
catchRAW (fromAction act) (\(e :: SomeException) -> liftIO clean >> throwRAW e)
actionFinally :: Action a -> IO b -> Action a
actionFinally act clean = do
res <- actionOnException act clean
liftIO clean
return res
run :: ShakeOptions -> Rules () -> IO ()
run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do
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
except <- newIORef (Nothing :: Maybe (String, SomeException))
let staunch act | not shakeStaunch = act >> return ()
| otherwise = do
res <- try act
case res of
Left err -> do
let named = maybe "unknown rule" shakeExceptionTarget . cast
atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())
let msg = show err ++ "Continuing due to staunch mode, this error will be repeated later"
when (shakeVerbosity >= Quiet) $ output Quiet msg
Right _ -> return ()
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)]
""
progressThread <- newIORef Nothing
after <- newIORef []
absent <- newIORef []
let cleanup = do
flip whenJust killThread =<< readIORef progressThread
when shakeTimings printTimings
resetTimings
shakeThreads <- if shakeThreads == 0 then getProcessorCount else return shakeThreads
flip finally cleanup $
withCapabilities shakeThreads $ do
withDatabase opts diagnostic $ \database -> do
tid <- forkIO $ shakeProgress $ do
failure <- fmap (fmap fst) $ readIORef except
stats <- progress database
return stats{isFailure=failure}
writeIORef progressThread $ Just tid
let ruleinfo = createRuleinfo opts rs
addTiming "Running rules"
runPool (shakeThreads == 1) shakeThreads $ \pool -> do
let s0 = Global database pool start ruleinfo output opts diagnostic lint after absent
let s1 = Local emptyStack shakeVerbosity Nothing [] 0 [] [] []
mapM_ (addPool pool . staunch . runAction s0 s1) (actions rs)
when (isJust shakeLint) $ do
addTiming "Lint checking"
absent <- readIORef absent
checkValid database (runStored ruleinfo) absent
when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"
when (isJust shakeReport) $ do
addTiming "Profile report"
let file = fromJust shakeReport
json <- showJSON database
when (shakeVerbosity >= Normal) $
output Normal $ "Writing HTML report to " ++ file
buildReport json file
maybe (return ()) (throwIO . snd) =<< readIORef except
sequence_ . reverse =<< readIORef after
lineBuffering :: IO a -> IO a
lineBuffering = withBufferMode stdout LineBuffering . withBufferMode stderr LineBuffering
abbreviate :: [(String,String)] -> String -> String
abbreviate [] = id
abbreviate abbrev = f
where
ordAbbrev = reverse $ sortBy (compare `on` 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
wrapStack :: IO [String] -> IO a -> IO a
wrapStack stk act = E.catch act $ \(SomeException e) -> case cast e of
Just s@ShakeException{} -> throwIO s
Nothing -> do
stk <- stk
if null stk then throwIO e
else throwIO $ ShakeException (last stk) stk $ SomeException e
runAction :: Global -> Local -> Action a -> IO 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 = f
where
f :: forall key value . Rule key value => [key] -> Action [value]
f ks = do
let tk = typeOf (err "apply key" :: key)
tv = typeOf (err "apply type" :: value)
Global{..} <- Action getRO
block <- Action $ getsRW localBlockApply
whenJust block $ errorNoApply tk (fmap show $ listToMaybe ks)
case Map.lookup tk globalRules of
Nothing -> errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv)
Just RuleInfo{resultType=tv2} | tv /= tv2 -> errorRuleTypeMismatch tk (fmap 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 = try $ wrapStack (showStack globalDatabase stack) $ do
evaluate $ rnf k
let s = Local {localVerbosity=shakeVerbosity globalOptions, localDepends=[], localStack=stack, localBlockApply=Nothing
,localDiscount=0, localTraces=[], localTrackAllows=[], localTrackUsed=[]}
let top = showTopStack stack
globalLint $ "before building " ++ top
(dur,(res,Local{..})) <- duration $ runAction global s $ do
putWhen Chatty $ "# " ++ show k
res <- runExecute globalRules k
when (shakeLint globalOptions == Just LintTracker)
trackCheckUsed
Action $ fmap ((,) res) getRW
globalLint $ "after building " ++ top
let ans = (res, reverse localDepends, dur localDiscount, reverse localTraces)
evaluate $ rnf ans
return ans
stack <- Action $ getsRW localStack
res <- liftIO $ build globalPool globalDatabase (Ops (runStored globalRules) exec) stack ks
case res of
Left err -> throw err
Right (dur, dep, vs) -> do
Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}
return vs
apply1 :: Rule key value => key -> Action value
apply1 = fmap head . apply . return
getShakeOptions :: Action ShakeOptions
getShakeOptions = Action $ getsRO globalOptions
traced :: String -> IO a -> Action a
traced msg act = do
Global{..} <- Action getRO
stack <- Action $ getsRW localStack
start <- liftIO globalTimestamp
putNormal $ "# " ++ msg ++ " " ++ showTopStack stack
res <- liftIO act
stop <- liftIO globalTimestamp
Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) start 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, putNormal, putQuiet :: String -> Action ()
putLoud = putWhen Loud
putNormal = putWhen Normal
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 ::
#if __GLASGOW_HASKELL__ >= 704
ShakeValue key
#else
(Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key)
#endif
=> 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
("Link 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 -> fmap (not . null) $ lookupDependencies globalDatabase k
unless (null bad) $ do
let n = length bad
errorStructured
("Link 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 ::
#if __GLASGOW_HASKELL__ >= 704
ShakeValue key
#else
(Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key)
#endif
=> 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 ::
#if __GLASGOW_HASKELL__ >= 704
ShakeValue key
#else
(Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key)
#endif
=> (key -> Bool) -> Action ()
trackAllow test = Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s}
where
arrow1Type :: forall a b . Typeable a => (a -> b) -> TypeRep
arrow1Type _ = typeOf (err "trackAllow" :: a)
ty = arrow1Type test
f k = typeKey k == ty && test (fromKey k)
newResource :: String -> Int -> Rules Resource
newResource name mx = rulesIO $ newResourceIO name mx
newThrottle :: String -> Int -> Double -> Rules Resource
newThrottle name count period = rulesIO $ newThrottleIO name count period
blockApply :: String -> Action a -> Action a
blockApply msg = Action . unmodifyRW f . fromAction
where f s0 = (s0{localBlockApply=Just msg}, \s -> s{localBlockApply=localBlockApply s0})
withResource :: Resource -> Int -> Action a -> Action a
withResource r i act = Action $ do
Global{..} <- getRO
act <- evalRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) act
join $ liftIO $ bracket_
(do res <- acquireResource r i
case res of
Nothing -> globalDiagnostic $ show r ++ " acquired " ++ show i ++ " with no wait"
Just wait -> do
globalDiagnostic $ show r ++ " waiting to acquire " ++ show i
blockPool globalPool $ fmap ((,) False) wait
globalDiagnostic $ show r ++ " acquired " ++ show i ++ " after waiting")
(do releaseResource r i
globalDiagnostic $ show r ++ " released " ++ show i)
act
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 -> do
join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of
Just bar -> return $ (,) mp $ do
res <- liftIO $ waitBarrierMaybe bar
res <- case res of
Nothing -> do pool <- Action $ getsRO globalPool; liftIO $ blockPool pool $ fmap ((,) False) $ waitBarrier bar
Just res -> return res
case res of
Left err -> Action $ throwRAW err
Right (deps,v) -> do
Action $ modifyRW $ \s -> s{localDepends = deps ++ localDepends s}
return v
Nothing -> do
bar <- newBarrier
return $ (,) (Map.insert key bar mp) $ do
pre <- Action $ getsRW localDepends
res <- Action $ tryRAW $ fromAction $ act key
case res of
Left err -> do
liftIO $ signalBarrier bar $ Left (err :: SomeException)
Action $ throwRAW err
Right v -> do
post <- Action $ getsRW localDepends
let deps = take (length post length pre) post
liftIO $ signalBarrier bar (Right (deps, v))
return v
newCache :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)
newCache = rulesIO . newCacheIO
unsafeExtraThread :: Action a -> Action a
unsafeExtraThread act = Action $ do
Global{..} <- getRO
act <- evalRAW $ fromAction act
join $ liftIO $ blockPool globalPool $ fmap ((,) False) act