module Development.Shake.Core(
ShakeOptions(..), shakeOptions, run,
Rule(..), Rules, defaultRule, rule, action,
Action, apply, apply1, traced, currentStack, currentRule,
putLoud, putNormal, putQuiet
) where
import Prelude hiding (catch)
import Control.Concurrent.ParallelIO.Local
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Binary(Binary)
import Data.Hashable
import Data.Function
import Data.List
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.Time.Clock
import Data.Typeable
import System.IO.Unsafe
import Development.Shake.Database
import Development.Shake.Locks
import Development.Shake.Value
data ShakeOptions = ShakeOptions
{shakeFiles :: FilePath
,shakeParallel :: Int
,shakeVersion :: Int
,shakeVerbosity :: Int
}
deriving (Show, Eq, Ord, Read)
shakeOptions :: ShakeOptions
shakeOptions = ShakeOptions ".shake" 1 1 1
data ShakeException = ShakeException [Key] SomeException
deriving Typeable
instance Exception ShakeException
instance Show ShakeException where
show (ShakeException stack inner) = unlines $
"Error when running Shake build system:" :
map (("* " ++) . show) stack ++
[show inner]
class (
Show key, Typeable key, Eq key, Hashable key, Binary key,
Show value, Typeable value, Eq value, Hashable value, Binary value
) => Rule key value | key -> value where
validStored :: key -> value -> IO Bool
validStored _ _ = return True
data ARule = forall key value . Rule key value => ARule (key -> Maybe (Action value))
ruleKey :: Rule key value => (key -> Maybe (Action value)) -> key
ruleKey = undefined
ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value
ruleValue = undefined
ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> Bool)
ruleStored _ k v = unsafePerformIO $ validStored k v
data Rules a = Rules
{value :: a
,actions :: [Action ()]
,rules :: [(Int,ARule)]
}
instance Monoid a => Monoid (Rules a) where
mempty = return mempty
mappend a b = (a >> b){value = value a `mappend` value b}
instance Monad Rules where
return x = Rules x [] []
Rules v1 x1 x2 >>= f = Rules v2 (x1++y1) (x2++y2)
where Rules v2 y1 y2 = f v1
instance Functor Rules where
fmap f x = return . f =<< x
defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()
defaultRule r = mempty{rules=[(0,ARule r)]}
rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()
rule r = mempty{rules=[(1,ARule r)]}
action :: Action a -> Rules ()
action a = mempty{actions=[a >> return ()]}
data S = S
{database :: Database
,pool :: Pool
,started :: UTCTime
,stored :: Key -> Value -> Bool
,execute :: Key -> Action Value
,outputLock :: Var ()
,verbosity :: Int
,stack :: [Key]
,depends :: [[Key]]
,discount :: Double
,traces :: [(String, Double, Double)]
}
newtype Action a = Action (StateT S IO a)
deriving (Functor, Monad, MonadIO)
run :: ShakeOptions -> Rules () -> IO ()
run ShakeOptions{..} rules = do
start <- getCurrentTime
registerWitnesses rules
outputLock <- newVar ()
withDatabase shakeFiles shakeVersion $ \database -> do
withPool shakeParallel $ \pool -> do
let s0 = S database pool start (createStored rules) (createExecute rules) outputLock shakeVerbosity [] [] 0 []
parallel_ pool $ map (wrapStack [] . runAction s0) (actions rules)
wrapStack :: [Key] -> IO a -> IO a
wrapStack stk act = catch act $ \(SomeException e) -> case cast e of
Just s@ShakeException{} -> throw s
Nothing -> throw $ ShakeException stk $ SomeException e
registerWitnesses :: Rules () -> IO ()
registerWitnesses Rules{..} =
forM_ rules $ \(_, ARule r) -> do
registerWitness $ ruleKey r
registerWitness $ ruleValue r
createStored :: Rules () -> (Key -> Value -> Bool)
createStored Rules{..} = \k v ->
let (tk,tv) = (typeKey k, typeValue v)
msg = "Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv ++
", perhaps you are missing a call to defaultRule/rule?"
in (fromMaybe (error msg) $ Map.lookup tk mp) k v
where mp = Map.fromList
[ (typeOf $ ruleKey r, stored)
| (_,ARule r) <- rules
, let stored k v = ruleStored r (fromKey k) (fromValue v)]
createExecute :: Rules () -> (Key -> Action Value)
createExecute Rules{..} = \k ->
let tk = typeKey k
rs = fromMaybe [] $ Map.lookup tk mp
in case filter (not . null) $ map (mapMaybe ($ k)) rs of
[r]:_ -> r
rs ->
let s = if null rs then "no" else show (length $ head rs)
in error $ "Error: " ++ s ++ " rules match for Rule " ++ show tk ++
", with key " ++ show k
where
mp = Map.map (map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst)) $ Map.fromListWith (++)
[ (typeOf $ ruleKey r, [(i,exec)])
| (i,ARule r) <- rules
, let exec k = fmap (fmap newValue) $ r (fromKey k)]
runAction :: S -> Action a -> IO (a, S)
runAction s (Action x) = runStateT x s
duration :: UTCTime -> UTCTime -> Double
duration start end = fromRational $ toRational $ end `diffUTCTime` start
apply :: Rule key value => [key] -> Action [value]
apply ks = Action $ do
modify $ \s -> s{depends=map newKey ks:depends s}
loop
where
loop = do
s <- get
res <- liftIO $ request (database s) (stored s) $ map newKey ks
case res of
Block act -> discounted (liftIO $ extraWorkerWhileBlocked (pool s) act) >> loop
Response vs -> return $ map fromValue vs
Execute todo -> do
let bad = intersect (stack s) todo
if not $ null bad then
error $ "Invalid rules, recursion detected when trying to build: " ++ show (head bad)
else do
discounted $ liftIO $ parallel_ (pool s) $ flip map todo $ \t ->
wrapStack (reverse $ t:stack s) $ do
start <- getCurrentTime
let s2 = s{depends=[], stack=t:stack s, discount=0, traces=[]}
(res,s2) <- runAction s2 $ do
putNormal $ "# " ++ show t
execute s t
end <- getCurrentTime
let x = duration start end discount s2
finished (database s) t res (reverse $ depends s2) x (reverse $ traces s2)
loop
discounted x = do
start <- liftIO getCurrentTime
res <- x
end <- liftIO getCurrentTime
modify $ \s -> s{discount=discount s + duration start end}
apply1 :: Rule key value => key -> Action value
apply1 = fmap head . apply . return
traced :: String -> IO a -> Action a
traced msg act = Action $ do
start <- liftIO getCurrentTime
res <- liftIO act
stop <- liftIO getCurrentTime
modify $ \s -> s{traces = (msg,duration (started s) start, duration (started s) stop):traces s}
return res
currentStack :: Action [Key]
currentStack = Action $ fmap reverse $ gets stack
currentRule = Action $ fmap listToMaybe $ gets stack
putWhen :: (Int -> Bool) -> String -> Action ()
putWhen f msg = Action $ do
s <- get
when (f $ verbosity s) $
liftIO $ modifyVar_ (outputLock s) $ const $
putStrLn msg
putLoud, putNormal, putQuiet :: String -> Action ()
putLoud = putWhen (>= 2)
putNormal = putWhen (>= 1)
putQuiet = putWhen (>= 0)