module Development.Hake (
Rule
, hake
, hakeT
, hakefileIs
, base
, file
, task
, rule
, ruleSS
, dflt
, mkfl
, systemE
, isSuffixOf
, changeSuffix
, ExitCode(ExitSuccess)
) where
import System.Environment (getArgs)
import System.Exit (ExitCode(ExitSuccess), exitWith)
import System.Cmd (system)
import System.Directory (doesFileExist)
import System.Directory.Tools (maybeGetModificationTime)
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Monad.Reader (asks, ReaderT(runReaderT), lift)
import Control.Monad.Tools (ifM, whenM)
import Control.Applicative ((<$>), liftA2)
import Control.Applicative.Tools ((<.>))
import Control.Arrow (second)
import Data.List (isSuffixOf)
import Data.List.Tools (mulLists)
import Data.Function.Tools (const2)
import Development.Hake.HiddenTools (runHake, hakefileUpdateOption, defaultTrgtStr)
type Targets = [ String -> Bool ]
type Sources = String -> SourcesRet
type Commands = String -> [ String ] -> [ CommandRet ]
type Rule = ( Targets, Sources, Commands )
type RuleInner = ( Targets, (Sources, Commands) )
type TargetRet = String
type SourcesRet = [ String ]
type CommandIO = ReaderT (Bool, MadeFromList) IO
type CommandRet = CommandIO ExitCode
type RuleRet = ( TargetRet, (SourcesRet, [CommandRet]) )
type MadeFromList = [ (FilePath, [FilePath]) ]
ruleToRuleInner :: Rule -> RuleInner
ruleToRuleInner ( x, y, z ) = ( x, (y, z) )
ruleRetToMadeFromList :: [ RuleRet ] -> MadeFromList
ruleRetToMadeFromList = map (\(x, (y, _)) -> (x, y))
hake :: [ Rule ] -> IO ()
hake rl = do args <- getArgs
let ud = elem hakefileUpdateOption args
trgts = filter (/=hakefileUpdateOption) args
mapM_ (hakeTarget ud (map ruleToRuleInner rl)) trgts
hakeT :: [ Rule ] -> FilePath -> IO ()
hakeT = hakeTarget True . map ruleToRuleInner
hakeTarget :: Bool -> [ RuleInner ] -> FilePath -> IO ()
hakeTarget ud rls fn = do
rrls <- traceRule fn rls
case rrls of
[] -> error $ "No usable rules for make target '" ++ fn ++ "'"
r:_ -> flip runReaderT (ud, ruleRetToMadeFromList r) $ mapM_ applyRule $ reverse r
traceRule :: FilePath -> [ RuleInner ] -> IO [[ RuleRet ]]
traceRule trgt rls
= case myLookup trgt rls of
[] -> ifM (doesFileExist trgt) (return [[]]) (return [])
finds -> do
optional <- ifM (doesFileExist trgt) (return [[]]) (return [])
fmap (++optional) $ concat <.> flip mapM finds $ \((tToS, tsToCmds), restRls) -> do
let srcs = tToS trgt
cmds = tsToCmds trgt srcs
obtainedRls <- mapM (unsafeInterleaveIO . flip traceRule restRls) srcs
return $ map ( (( trgt, (srcs, cmds) ):) . concat ) $ mulLists obtainedRls
applyRule :: (TargetRet, (SourcesRet, [CommandRet])) -> CommandRet
applyRule (src, (dsts, cmds))
= ifM ( lift $ isOldThanSomeOf src dsts )
( abortIfFailure cmds )
( return ExitSuccess )
isOldThanSomeOf :: FilePath -> [FilePath] -> IO Bool
isOldThanSomeOf dfn sfns
= liftA2 ((myOr .) . map . (<)) (maybeGetModificationTime dfn)
(mapM maybeGetModificationTime sfns)
where
myOr [] = True
myOr bs = or bs
myLookup :: a -> [ ([a -> Bool], b) ] -> [ (b, [ ([a -> Bool], b) ]) ]
myLookup _ [] = []
myLookup x (pair@(p, y):rest)
| or $ map ($x) p
= (y, rest) : ( second (pair:) <$> myLookup x rest )
| otherwise
= second (pair:) <$> myLookup x rest
changeSuffix :: String -> String -> String -> String
changeSuffix oldSfx newSfx fn
| isSuffixOf oldSfx fn = take (length fn length oldSfx) fn ++ newSfx
| otherwise = error $ "changeSuffix: " ++ oldSfx ++ " is not suffix of " ++ fn
systemE :: String -> IO ExitCode
systemE cmd = putStrLn cmd >> system cmd
systemEInner :: String -> CommandRet
systemEInner cmd = lift $ putStrLn cmd >> system cmd
base :: ( Targets, Sources, String -> [ String ] -> [ MadeFromList -> IO ExitCode ] ) -> Rule
base (trgts, srcs, cmdsGen) = (trgts, srcs, cmds)
where cmds :: Commands
cmds t s = map cmdGenToCmd $ cmdsGen t s
cmdGenToCmd :: (MadeFromList -> IO ExitCode) -> CommandRet
cmdGenToCmd cg = do mfl <- asks snd
lift $ cg mfl
dflt :: [ String ] -> Rule
dflt trgts = ( [ (==defaultTrgtStr) ], const trgts, const2 [] )
file :: ( [String], [String], [String] ) -> Rule
file ( trgts, srcs, cmd ) = ( map (==) trgts, const srcs, const2 $ map systemEInner cmd )
task :: ( String, [String] ) -> Rule
task ( trgts, cmd ) = ( [(==trgts)], const [], const2 $ map systemEInner cmd )
rule :: ( String, String, String -> String -> [String] ) -> Rule
rule ( trgt, src, cmd )
= ( [isSuffixOf trgt], \dst -> [changeSuffix trgt src dst ],
\t [s] -> map systemEInner $ cmd t s )
ruleSS :: ( String, String, String -> String -> [ (String, [String]) ] ) -> Rule
ruleSS ( trgt, src, cmds )
= ( [ isSuffixOf trgt ], \dst -> [ changeSuffix trgt src dst ],
\t [s] -> [ do [ srcSrc ] <- getSrcs s
abortIfFailure $ map systemEInner $
snd $ head $ filter ( flip isSuffixOf srcSrc . fst ) $ cmds t s ] )
abortIfFailure :: [ CommandRet ] -> CommandRet
abortIfFailure = (<.>) last $ mapM $ flip (>>=) $ \ec ->
case ec of
ExitSuccess -> return ec
_ -> lift $ exitWith ec
orM :: Monad m => m Bool -> m Bool -> m Bool
orM p1 p2 = do b1 <- p1
b2 <- p2
return $ b1 || b2
mkfl :: ( String, [ String ] ) -> Rule
mkfl ( trgt, cont )
= ( [ (==trgt) ], const [], \t -> const [ do
whenM (getUpdateStatus `orM` lift (not <$> doesFileExist trgt)) $ do
lift $ putStrLn $ "make file `" ++ trgt ++ "' (hake)"
lift $ writeFile t $ unlines cont
return ExitSuccess ] )
hakefileIs :: FilePath -> [ FilePath ] -> IO ExitCode
hakefileIs src others = do
args <- getArgs
runHake src "hake_" others $ if null args then [ defaultTrgtStr ] else args
getUpdateStatus :: CommandIO Bool
getUpdateStatus = asks fst
getSrcs :: FilePath -> CommandIO [FilePath]
getSrcs fp = asks (maybe [] id . lookup fp . snd)