hake-0.9.5: 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

, addDeps

, isSuffixOf
, changeSuffix
, ExitCode(ExitSuccess)
) where

import System.Environment           (getArgs)
import System.Exit                  (ExitCode(ExitSuccess))
import System.Directory             (doesFileExist)
import System.Directory.Tools       (maybeGetModificationTime)
import System.IO.Unsafe             (unsafeInterleaveIO)
import Control.Monad.Reader         (ReaderT(runReaderT), lift)
import Control.Monad.Tools          (ifM)
import Control.Applicative          ((<$>), liftA2)
import Control.Applicative.Tools    ((<.>))
import Control.Arrow                (second)
import Data.List                    (isSuffixOf)
import Data.List.Tools              (mulLists)
import Development.Hake.HiddenTools (runHake, hakefileUpdateOption,
                                     defaultTrgtStr, changeSuffix)
import Development.Hake.Types       (Rule, RuleInner,
                                     TargetRet, SourcesRet, CommandRet, RuleRet,
				     MadeFromList)

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, cmd))
  = ifM ( lift $ isOldThanSomeOf src dsts )
        cmd
        ( 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)
  | p x -- or $ map ($x) p
    = (y, rest) : ( second (pair:) <$> myLookup x rest )
  | otherwise
    =               second (pair:) <$> myLookup x rest

addDeps :: [ Rule ] -> [ (FilePath, [FilePath]) ] -> [ Rule ]
addDeps rls adrls = concatMap ad adrls ++ rls
  where
  ad :: (FilePath, [FilePath]) -> [ Rule ]
  ad (t, ss) = [ ((==t), const $ sgen t ++ ss, c) |
                 (testT, sgen, c) <- rls, testT t ]

hakefileIs :: FilePath -> [ FilePath ] -> IO ExitCode
hakefileIs src others = do
  args <- getArgs
  runHake src "hake_" others $ if null args then [ defaultTrgtStr ] else args