hake-0.7: Development/Hake.hs

{- hake: make tool. ruby : rake = haskell : hake
Copyright (C) 2008-2008 Yoshikuni Jujo <PAF01143@nifty.ne.jp>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Development.Hake (
  Rule
, hake
, hakeT
, hakefileIs

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

--, liftIO
, systemE
--, getSrcs
, 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.Tuple.Tools             (modifySnd)
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))

-- |The 'hake' function take rules as argument and get target from command line and make target.
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
      -- for task like "clean"
      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)