module Development.Shake.Core(
ShakeOptions(..), shakeOptions, run,
Rule(..), Rules, defaultRule, rule, action, withoutActions,
Action, apply, apply1, traced,
Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet,
Resource, newResource, withResource
) where
import Control.DeepSeq
import Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Binary(Binary)
import Data.Data
import Data.Hashable
import Data.Function
import Data.List
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Data.Monoid
import Development.Shake.Pool
import Development.Shake.Database
import Development.Shake.Locks
import Development.Shake.Value
import Development.Shake.Report
data ShakeOptions = ShakeOptions
{shakeFiles :: FilePath
,shakeThreads :: Int
,shakeVersion :: Int
,shakeVerbosity :: Verbosity
,shakeStaunch :: Bool
,shakeReport :: Maybe FilePath
,shakeLint :: Bool
,shakeDeterministic :: Bool
}
deriving (Show,Eq,Ord,Typeable,Data)
shakeOptions :: ShakeOptions
shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False
data ShakeException = ShakeException
[String]
SomeException
deriving Typeable
instance Exception ShakeException
instance Show ShakeException where
show (ShakeException stack inner) = unlines $
"Error when running Shake build system:" :
map ("* " ++) stack ++
[show inner]
data Verbosity
= Silent
| Quiet
| Normal
| Loud
| Diagnostic
deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data)
class (
Show key, Typeable key, Eq key, Hashable key, Binary key, NFData key,
Show value, Typeable value, Eq value, Hashable value, Binary value, NFData 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 -> IO Bool)
ruleStored _ = validStored
data Rules a = Rules
{value :: a
,actions :: [Action ()]
,rules :: Map.HashMap TypeRep (TypeRep,TypeRep,[(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 [] (Map.fromList [])
Rules v1 x1 x2 >>= f = case f v1 of
Rules v2 y1 y2 -> Rules v2 (x1++y1) (Map.unionWith g x2 y2)
where g (k, v1, xs) (_, v2, ys)
| v1 == v2 = (k, v1, xs ++ ys)
| otherwise = error $ "There are two incompatible rules for " ++ show k ++ ", producing " ++ show v1 ++ " and " ++ show v2
instance Functor Rules where
fmap f x = return . f =<< x
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 = 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 = mempty{actions=[a >> return ()]}
withoutActions :: Rules () -> Rules ()
withoutActions x = x{actions=[]}
data S = S
{database :: Database
,pool :: Pool
,started :: IO Time
,stored :: Key -> Value -> IO Bool
,execute :: Key -> Action Value
,output :: String -> IO ()
,verbosity :: Verbosity
,logger :: String -> IO ()
,stack :: Stack
,depends :: [Depends]
,discount :: Duration
,traces :: [(String, Time, Time)]
}
newtype Action a = Action (StateT S IO a)
deriving (Functor, Monad, MonadIO)
run :: ShakeOptions -> Rules () -> IO ()
run opts@ShakeOptions{..} rs = do
start <- startTime
registerWitnesses rs
output <- do
lock <- newLock
return $ withLock lock . putStrLn
let logger = if shakeVerbosity >= Diagnostic then output . ("% "++) else const $ return ()
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 msg
Right _ -> return ()
let stored = createStored rs
let execute = createExecute rs
withDatabase logger shakeFiles shakeVersion $ \database -> do
runPool shakeDeterministic shakeThreads $ \pool -> do
let s0 = S database pool start stored execute output shakeVerbosity logger emptyStack [] 0 []
mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs)
when shakeLint $ do
checkValid database stored
when (shakeVerbosity >= Loud) $ output "Lint checking succeeded"
when (isJust shakeReport) $ do
let file = fromJust shakeReport
json <- showJSON database
when (shakeVerbosity >= Normal) $
putStrLn $ "Writing HTML report to " ++ file
buildReport json file
maybe (return ()) throwIO =<< readVar except
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 :: Rules () -> IO ()
registerWitnesses Rules{..} =
forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do
registerWitness $ ruleKey r
registerWitness $ ruleValue r
createStored :: Rules () -> (Key -> Value -> IO Bool)
createStored Rules{..} = \k v ->
let (tk,tv) = (typeKey k, typeValue v) in
case Map.lookup tk mp of
Nothing -> error $
"Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv ++
", perhaps you are missing a call to defaultRule/rule?"
Just (tv2,_) | tv2 /= tv -> error $
"Error: couldn't find instance Rule " ++ show tk ++ " " ++ show tv ++
", but did find an instance Rule " ++ show tk ++ " " ++ show tv2 ++
", perhaps you have the types wrong in your call to apply?"
Just (_, r) -> r k v
where
mp = flip Map.map rules $ \(k,v,(_,ARule r):_) -> (v, \kx vx -> ruleStored r (fromKey kx) (fromValue vx))
createExecute :: Rules () -> (Key -> Action Value)
createExecute Rules{..} = \k ->
let tk = typeKey k in
case Map.lookup tk mp of
Nothing -> error $
"Error: couldn't find any rules to build " ++ show k ++ " of type " ++ show tk ++
", perhaps you are missing a call to defaultRule/rule?"
Just rs -> 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 k ++ " of type " ++ show tk
where
mp = flip Map.map rules $ \(_,_,rs) -> 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)
runAction :: S -> Action a -> IO (a, S)
runAction s (Action x) = runStateT x s
apply :: Rule key value => [key] -> Action [value]
apply ks = fmap (map fromValue) $ applyKeyValue $ map newKey ks
applyKeyValue :: [Key] -> Action [Value]
applyKeyValue ks = Action $ do
s <- get
let exec stack k = try $ wrapStack (showStack (database s) stack) $ do
evaluate $ rnf k
let s2 = s{depends=[], stack=stack, discount=0, traces=[]}
(dur,(res,s2)) <- duration $ runAction s2 $ do
putNormal $ "# " ++ show k
execute s k
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 (stored s) exec) (stack s) ks
case res of
Left err -> throw err
Right (dur, dep, vs) -> do
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 = Action $ do
s <- get
start <- liftIO $ started s
res <- liftIO act
stop <- liftIO $ started s
modify $ \s -> s{traces = (msg,start,stop):traces s}
return res
putWhen :: (Verbosity -> Bool) -> String -> Action ()
putWhen f msg = Action $ do
s <- get
when (f $ verbosity s) $
liftIO $ output s msg
putLoud, putNormal, putQuiet :: String -> Action ()
putLoud = putWhen (>= Loud)
putNormal = putWhen (>= Normal)
putQuiet = putWhen (>= Quiet)
getVerbosity :: Action Verbosity
getVerbosity = Action $ gets verbosity
withResource :: Resource -> Int -> Action a -> Action a
withResource r i act = Action $ do
s <- get
(res,s) <- liftIO $ bracket_
(do res <- acquireResource r i
case res of
Nothing -> logger s $ show r ++ " acquired " ++ show i ++ " with no wait"
Just wait -> do
logger s $ show r ++ " waiting to acquire " ++ show i
blockPool (pool s) $ fmap ((,) False) wait
logger s $ show r ++ " acquired " ++ show i ++ " after waiting")
(do releaseResource r i
logger s $ show r ++ " released " ++ show i)
(runAction s act)
put s
return res