FunSet.hs

module Development.Hake.FunSet (

  base
, file
, task
, rule
, 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, 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 ] )

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)