FunSet.hs

module Development.Hake.FunSet (

  base
, file
, task
, rule
, ruleV
, ruleSS
, dflt
, mkfl

, systemE

) where

import System.Directory             (doesFileExist)
import System.Cmd                   (rawSystem)
import System.Exit                  (ExitCode(ExitSuccess))
import Data.List                    (isSuffixOf)
import Data.Function.Tools          (const2)
import Control.Monad.Reader         (lift, asks)
import Control.Monad.Tools          (whenM)
import Control.Applicative          ((<$>))
import Development.Hake.Types       (Rule, CommandRet, MadeFromList,
                                     Commands, Targets, Sources,
				     getSrcs, getUpdateStatus)
import Development.Hake.HiddenTools (abortIfFailure, changeSuffix,
                                     defaultTrgtStr)

base ::
  Targets -> Sources
          -> ( String -> [ String ] -> MadeFromList -> IO ExitCode )
          -> Rule
base trgts srcs cmdsGen = (trgts, srcs, cmd)
  where cmd :: Commands
        cmd t s = 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 $ return ExitSuccess )

file :: [String] -> [String] -> [[String]] -> Rule
file trgts srcs cmd
  = ( \f -> or $ map (==f) trgts, const srcs, const2 $ abortIfFailure $ map systemEInner cmd )

task :: String -> [[String]] -> Rule
task trgts cmd = ( (==trgts), const [], const2 $ abortIfFailure $ map systemEInner cmd )

rule :: String -> String -> (String -> [String] -> [[String]]) -> Rule
rule trgt src cmd
  = ( isSuffixOf trgt, \dst -> [changeSuffix trgt src dst ],
      \t s -> abortIfFailure $ map systemEInner $ cmd t s )

ruleV :: String -> [String] -> [String] -> (String -> [String] -> [[String]]) -> Rule
ruleV trgt srcs cmmns cmd
  = ( isSuffixOf trgt, \dst -> map (flip (changeSuffix trgt) dst) srcs ++ cmmns,
        \t s -> abortIfFailure $ 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 $ head s
	           abortIfFailure $ map systemEInner $
		     snd $ head $ filter ( flip isSuffixOf srcSrc . fst ) $ cmds t s )

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 )

orM :: Monad m => m Bool -> m Bool -> m Bool
orM p1 p2 = do b1 <- p1
               b2 <- p2
	       return $ b1 || b2

systemE :: [ String ] -> IO ExitCode
systemE cmd = putStrLn (unwords cmd) >> rawSystem (head cmd) (tail cmd)

systemEInner :: [ String ] -> CommandRet
systemEInner cmd = lift $ putStrLn (unwords cmd) >> rawSystem (head cmd) (tail cmd)