#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 Control.Monad.Trans.State.Strict as State
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
#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 = forall key value . Rule key value => ARule (key -> Maybe (Action value))
ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key
ruleKey = err "ruleKey"
ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value
ruleValue = err "ruleValue"
newtype Rules a = Rules (WriterT SRules IO a)
deriving (Monad, Functor, Applicative)
rulesIO :: IO a -> Rules a
rulesIO = Rules . liftIO
newRules :: SRules -> Rules ()
newRules = Rules . tell
modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()
modifyRules f (Rules r) = Rules $ censor f r
getRules :: Rules () -> IO SRules
getRules (Rules r) = execWriterT r
data SRules = SRules
{actions :: [Action ()]
,rules :: Map.HashMap TypeRep (TypeRep,TypeRep,[(Int,ARule)])
}
instance Monoid SRules 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 a b = do a <- a; b <- b; return $ mappend a b
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
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
s <- Action State.get
deps <- liftIO $ concatMapM (listDepends $ database s) (depends s)
let top = topStack $ stack s
if top == Just k then
return ()
else if k `elem` deps then
return ()
else if any ($ k) $ trackAllows s then
return ()
else
Action $ State.modify $ \s -> s{trackUsed = k : trackUsed s}
trackCheckUsed :: Action ()
trackCheckUsed = do
s <- Action State.get
deps <- liftIO $ concatMapM (listDepends $ database s) (depends s)
bad <- return $ trackUsed s \\ 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 <- liftIO $ flip filterM (trackUsed s) $ \k -> fmap (not . null) $ lookupDependencies (database s) 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
s <- Action State.get
let top = topStack $ stack s
if top == Just k then
return ()
else if any ($ k) $ trackAllows s then
return ()
else
liftIO $ atomicModifyIORef (trackAbsent s) $ \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 $ State.modify $ \s -> s{trackAllows = f : trackAllows 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)
action :: Action a -> Rules ()
action a = newRules mempty{actions=[a >> return ()]}
withoutActions :: Rules () -> Rules ()
withoutActions = modifyRules $ \x -> x{actions=[]}
data RuleInfo = RuleInfo
{stored :: Key -> IO (Maybe Value)
,execute :: Key -> Action Value
,resultType :: TypeRep
}
data SAction = SAction
{database :: Database
,pool :: Pool
,timestamp :: IO Time
,ruleinfo :: Map.HashMap TypeRep RuleInfo
,output :: Verbosity -> String -> IO ()
,opts :: ShakeOptions
,diagnostic :: String -> IO ()
,lint :: String -> IO ()
,after :: IORef [IO ()]
,trackAbsent :: IORef [(Key, Key)]
,stack :: Stack
,verbosity :: Verbosity
,depends :: [Depends]
,discount :: !Duration
,traces :: [Trace]
,blockapply :: Maybe String
,trackAllows :: [Key -> Bool]
,trackUsed :: [Key]
}
newtype Action a = Action (StateT SAction IO a)
deriving (Monad, MonadIO, Functor, Applicative)
actionOnException :: Action a -> IO b -> Action a
actionOnException act clean = do
s <- Action State.get
(res,s) <- liftIO $ onException (runAction s act) clean
Action $ State.put s
return res
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 = SAction database pool start ruleinfo output opts diagnostic lint after absent emptyStack shakeVerbosity [] 0 [] Nothing [] []
mapM_ (addPool pool . staunch . runAction s0) (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
withCapabilities :: Int -> IO a -> IO a
#if __GLASGOW_HASKELL__ >= 706
withCapabilities new act = do
old <- getNumCapabilities
if old == new then act else
bracket_ (setNumCapabilities new) (setNumCapabilities old) act
#else
withCapabilities new act = act
#endif
lineBuffering :: IO a -> IO a
lineBuffering = f stdout . f stderr
where
f h act = do
bracket (hGetBuffering h) (hSetBuffering h) $ const $ do
hSetBuffering h LineBuffering
act
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
registerWitnesses :: SRules -> IO ()
registerWitnesses SRules{..} =
forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do
registerWitness $ ruleKey r
registerWitness $ ruleValue r
createRuleinfo :: ShakeOptions -> SRules -> Map.HashMap TypeRep RuleInfo
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 (Action 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 -> 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 -> Key -> Action 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
runAction :: SAction -> Action a -> IO (a, SAction)
runAction s (Action x) = runStateT x s
runAfter :: IO () -> Action ()
runAfter op = do
s <- Action State.get
liftIO $ atomicModifyIORef (after s) $ \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)
ruleinfo <- Action $ State.gets ruleinfo
block <- Action $ State.gets blockapply
whenJust block $ errorNoApply tk (fmap show $ listToMaybe ks)
case Map.lookup tk ruleinfo 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
s <- Action State.get
let exec stack k = try $ wrapStack (showStack (database s) stack) $ do
evaluate $ rnf k
let s2 = s{verbosity=shakeVerbosity $ opts s, depends=[], stack=stack, discount=0, traces=[], trackAllows=[], trackUsed=[]}
let top = showTopStack stack
lint s $ "before building " ++ top
(dur,(res,s2)) <- duration $ runAction s2 $ do
putWhen Chatty $ "# " ++ show k
res <- runExecute (ruleinfo s) k
when (shakeLint (opts s) == Just LintTracker)
trackCheckUsed
return res
lint s $ "after building " ++ top
let ans = (res, reverse $ depends s2, dur discount s2, reverse $ traces s2)
evaluate $ rnf ans
return ans
res <- liftIO $ build (pool s) (database s) (Ops (runStored (ruleinfo s)) exec) (stack s) ks
case res of
Left err -> throw err
Right (dur, dep, vs) -> do
Action $ State.modify $ \s -> s{discount=discount s + dur, depends=dep : depends s}
return vs
apply1 :: Rule key value => key -> Action value
apply1 = fmap head . apply . return
getShakeOptions :: Action ShakeOptions
getShakeOptions = Action $ gets opts
traced :: String -> IO a -> Action a
traced msg act = do
s <- Action State.get
start <- liftIO $ timestamp s
putNormal $ "# " ++ msg ++ " " ++ showTopStack (stack s)
res <- liftIO act
stop <- liftIO $ timestamp s
Action $ State.modify $ \s -> s{traces = Trace (pack msg) start stop : traces s}
return res
putWhen :: Verbosity -> String -> Action ()
putWhen v msg = do
s <- Action State.get
when (verbosity s >= v) $
liftIO $ output s v msg
putLoud, putNormal, putQuiet :: String -> Action ()
putLoud = putWhen Loud
putNormal = putWhen Normal
putQuiet = putWhen Quiet
getVerbosity :: Action Verbosity
getVerbosity = Action $ gets verbosity
withVerbosity :: Verbosity -> Action a -> Action a
withVerbosity new act = do
old <- Action $ State.gets verbosity
Action $ State.modify $ \s -> s{verbosity=new}
res <- act
Action $ State.modify $ \s -> s{verbosity=old}
return res
quietly :: Action a -> Action a
quietly = withVerbosity Quiet
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 act = do
s0 <- Action State.get
Action $ State.put s0{blockapply=Just msg}
res <- act
Action $ State.modify $ \s -> s{blockapply=blockapply s0}
return res
withResource :: Resource -> Int -> Action a -> Action a
withResource r i act = do
s <- Action State.get
(res,s) <- liftIO $ bracket_
(do res <- acquireResource r i
case res of
Nothing -> diagnostic s $ show r ++ " acquired " ++ show i ++ " with no wait"
Just wait -> do
diagnostic s $ show r ++ " waiting to acquire " ++ show i
blockPool (pool s) $ fmap ((,) False) wait
diagnostic s $ show r ++ " acquired " ++ show i ++ " after waiting")
(do releaseResource r i
diagnostic s $ show r ++ " released " ++ show i)
(runAction s $ blockApply ("Within withResource using " ++ show r) act)
Action $ State.put s
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 -> 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 $ gets pool; liftIO $ blockPool pool $ fmap ((,) False) $ waitBarrier bar
Just res -> return res
case res of
Left err -> liftIO $ throwIO err
Right (deps,v) -> do
Action $ modify $ \s -> s{depends = deps ++ depends s}
return v
Nothing -> do
bar <- newBarrier
return $ (,) (Map.insert key bar mp) $ do
s <- Action State.get
let pre = depends s
res <- liftIO $ try $ runAction s $ act key
case res of
Left err -> liftIO $ do
signalBarrier bar $ Left (err :: SomeException)
throwIO err
Right (v,s) -> do
Action $ State.put s
let post = depends s
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 = do
s <- Action State.get
(res,s) <- liftIO $ blockPool (pool s) $ fmap ((,) False) $ runAction s act
Action $ State.put s
return res