# 1 "Development/Hake.cpphs"
# 1 "<built-in>"
# 1 "<command-line>"
# 13 "<command-line>"
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 13 "<command-line>" 2
# 1 "Development/Hake.cpphs"
module Development.Hake (
Rule
, hake
, hakeT
, hakefileIs
, file
, task
, rule
, ruleSS
, dflt
, mkfl
, lift
, systemE
, getSrcs
, isSuffixOf
, changeSuffix
, ExitCode(ExitSuccess)
) where
import System.Environment (getArgs)
import Data.List (isSuffixOf)
import System.Exit (ExitCode(ExitSuccess), exitWith)
import System.Cmd (system)
import System.Directory (doesFileExist)
import Control.Applicative ((<$>))
import Development.Hake.HiddenTools (isOldThanSomeOf, runHake, hakefileUpdateOption)
import Control.Monad.Reader (asks, ReaderT(runReaderT), lift)
import Control.Monad.Utils (ifM, whenM)
import System.IO.Unsafe (unsafeInterleaveIO
)
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
args_ = filter (/=hakefileUpdateOption) args
case args_ of
[ trgt ] -> hakeTarget ud (map ruleToRuleInner rl) trgt
_ -> error "function (hake): argument error"
hakeT :: [ Rule ] -> FilePath -> IO ()
hakeT = hakeTarget True . map ruleToRuleInner
hakeTarget :: Bool -> [ RuleInner ] -> FilePath -> IO ()
hakeTarget ud rls fn = do
rl <- traceRule fn rls
flip runReaderT (ud, ruleRetToMadeFromList $ head rl) $ mapM_ applyRule $ reverse $ head rl
infixr 9 <.>
(<.>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
f1 <.> f2 = fmap f1 . f2
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
mulLists :: [[a]] -> [[a]]
mulLists [] = [[]]
mulLists (xs:xss) = [ x:xs_ | x <- xs, xs_ <- mulLists xss ]
applyRule :: (TargetRet, (SourcesRet, [CommandRet])) -> CommandRet
applyRule (src, (dsts, cmds))
= ifM ( lift $ isOldThanSomeOf src dsts )
( abortIfFailure cmds )
( return ExitSuccess )
myLookup :: a -> [ ([a -> Bool], b) ] -> [ (b, [ ([a -> Bool], b) ]) ]
myLookup _ [] = []
myLookup x (pair@(p, y):rest)
| or $ map ($x) p
= (y, rest) : ( (\(z, ps) -> (z, pair:ps)) <$> myLookup x rest )
| otherwise
= (\(z, ps) -> (z, pair:ps)) <$> 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
const2 :: a -> b -> c -> a
const2 = const . const
systemE :: String -> CommandRet
systemE cmd = lift $ putStrLn cmd >> system cmd
dflt :: [ String ] -> Rule
dflt trgts = ( [ (=="default") ], const trgts, const2 [] )
file :: ( [String], [String], [String] ) -> Rule
file ( trgts, srcs, cmd ) = ( map (==) trgts, const srcs, const2 $ map systemE cmd )
task :: ( String, [String] ) -> Rule
task ( trgts, cmd ) = ( [(==trgts)], const [], const2 $ map systemE cmd )
rule :: ( String, String, String -> String -> [String] ) -> Rule
rule ( trgt, src, cmd )
= ( [isSuffixOf trgt], \dst -> [changeSuffix trgt src dst ],
\t [s] -> map systemE $ 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 systemE $
snd $ head $ filter ( flip isSuffixOf srcSrc . fst ) $ cmds t s ] )
abortIfFailure :: [ CommandRet ] -> CommandRet
abortIfFailure = last <.> mapM (>>= (\ec -> if ec == ExitSuccess then return ec else lift $ exitWith ec))
mkfl :: ( String, [ String ] ) -> Rule
mkfl ( trgt, cont )
= ( [(==trgt)], const [], \t -> const [ do
whenM getUpdateStatus $ 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 [ "default" ] else args
getUpdateStatus :: CommandIO Bool
getUpdateStatus = asks fst
getSrcs :: FilePath -> CommandIO [FilePath]
getSrcs fp = asks (maybe [] id . lookup fp . snd)