#if __GLASGOW_HASKELL__ >= 704
#endif
module Development.Shake.Core(
run,
#if __GLASGOW_HASKELL__ >= 704
ShakeValue,
#endif
Rule(..), Rules, defaultRule, rule, action, withoutActions,
Action, actionOnException, actionFinally, apply, apply1, traced,
getVerbosity, putLoud, putNormal, putQuiet, quietly,
Resource, newResource, newResourceIO, withResource,
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 Development.Shake.Classes
import Development.Shake.Pool
import Development.Shake.Database
import Development.Shake.Locks
import Development.Shake.Value
import Development.Shake.Report
import Development.Shake.Types
import Development.Shake.Errors
#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 :: 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
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 ()
,verbosity :: Verbosity
,diagnostic :: String -> IO ()
,lint :: String -> IO ()
,after :: IORef [IO ()]
,stack :: Stack
,depends :: [Depends]
,discount :: !Duration
,traces :: [Trace]
}
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 = do
start <- startTime
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 <- newVar (Nothing :: Maybe SomeException)
let staunch act | not shakeStaunch = act >> return ()
| otherwise = do
res <- try act
case res of
Left err -> do
modifyVar_ except $ \v -> return $ Just $ fromMaybe 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 not shakeLint then return $ const $ return () else do
dir <- getCurrentDirectory
return $ \msg -> do
now <- getCurrentDirectory
when (dir /= now) $ error $
"Lint checking failed, current directory has changed\n" ++
"When: " ++ msg ++ "\n" ++
"Wanted: " ++ dir ++ "\n" ++
"Got: " ++ now
let ruleinfo = createRuleinfo shakeAssume rs
running <- newIORef True
after <- newIORef []
flip finally (writeIORef running False) $ do
withDatabase opts diagnostic $ \database -> do
forkIO $ shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running}
runPool shakeDeterministic shakeThreads $ \pool -> do
let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 []
mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs)
when shakeLint $ do
checkValid database (runStored ruleinfo)
when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"
when (isJust shakeReport) $ do
let file = fromJust shakeReport
json <- showJSON database
when (shakeVerbosity >= Normal) $
output Normal $ "Writing HTML report to " ++ file
buildReport json file
maybe (return ()) throwIO =<< readVar except
sequence_ . reverse =<< readIORef after
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{} -> throw s
Nothing -> do
stk <- stk
throw $ ShakeException stk $ SomeException e
registerWitnesses :: SRules -> IO ()
registerWitnesses SRules{..} =
forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do
registerWitness $ ruleKey r
registerWitness $ ruleValue r
createRuleinfo :: Maybe Assume -> SRules -> Map.HashMap TypeRep RuleInfo
createRuleinfo assume 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
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
ruleinfo <- Action $ State.gets ruleinfo
let tk = typeOf (err "apply key" :: key)
tv = typeOf (err "apply type" :: value)
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 ks = do
s <- Action State.get
let exec stack k = try $ wrapStack (showStack (database s) stack) $ do
evaluate $ rnf k
let s2 = s{depends=[], stack=stack, discount=0, traces=[]}
lint s "before building"
(dur,(res,s2)) <- duration $ runAction s2 $ do
putLoud $ "# " ++ show k
runExecute (ruleinfo s) k
lint s "after building"
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
traced :: String -> IO a -> Action a
traced msg act = do
s <- Action State.get
start <- liftIO $ timestamp s
putNormal $ "# " ++ topStack (stack s) ++ " " ++ msg
res <- liftIO act
stop <- liftIO $ timestamp s
Action $ State.modify $ \s -> s{traces = (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
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 act)
Action $ State.put s
return res