HiddenTools.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.HiddenTools (
  runHake
, isOldThanSomeOf
, hakefileUpdateOption
, defaultTrgtStr
) where

import System.IO            (openFile, hClose, IOMode(WriteMode))
import System.Directory     (createDirectory, doesDirectoryExist,
                             doesFileExist, getModificationTime)
import System.Exit          (ExitCode(ExitSuccess))
import System.Time          (ClockTime)
import System.Process       (runProcess, waitForProcess)
import System.FilePath      (takeFileName)
import System.IO.Unsafe     (unsafeInterleaveIO)
import Control.Monad.Utils  (unlessM, ifM)
import Control.Applicative  ((<$>), liftA2)
import Control.Exception    (bracket)
import Data.List.Tools      (defaultElem)
import Data.Function.Tools  (applyWhen, apply2way)
import Text.RegexPR         (matchRegexPR)

hakeDir, defaultTrgtStr, hakefileUpdateOption :: String
hakeDir              = "_hake/"
defaultTrgtStr       = "default"
hakefileUpdateOption = "--hakefile-is-updated"

maybeGetModificationTime :: FilePath -> IO (Maybe ClockTime)
maybeGetModificationTime fn
  = ifM (doesFileExist fn)
        (Just <$> getModificationTime fn)
        (return Nothing)

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

runHake :: FilePath -> FilePath -> [ FilePath ] -> [ String ] -> IO ExitCode
runHake src exe othrs args = do
  let exePath = hakeDir ++ exe
      exeSrc  = hakeDir ++ exe ++ ".hs"
      cmtOut  = ("{- " ++) . ( ++ " -}\n")
      cmtIn   = (>>= lookup 1) . fmap snd . matchRegexPR "\\{-\\s*(\\S+)\\s*-\\}" . head . lines
  mapM_ errorExist $ src : othrs
  unlessM (doesDirectoryExist hakeDir) $ createDirectory hakeDir
  othrsUD    <- fmap or $ flip mapM othrs
                        $ apply2way (updateFile cmtIn cmtOut) id $ (hakeDir ++) . takeFileName
  hakefileUD <- updateFile cmtIn cmtOut src exeSrc
  ghcMake exe hakeDir
  let args_ = applyWhen (othrsUD || hakefileUD) (hakefileUpdateOption:) $
                defaultElem defaultTrgtStr args
  runProcess exePath args_ Nothing Nothing Nothing Nothing Nothing >>= waitForProcess

errorExist :: FilePath -> IO ()
errorExist fp = unlessM (doesFileExist fp) $
                  error $ "runHake: " ++ fp ++ " does not exist"

updateFile :: (String -> Maybe String) -> (FilePath -> String) -> FilePath -> FilePath -> IO Bool
updateFile gtSrc hdr src dst
  = ifM ( not <$> doesFileExist dst
          `orIO`
          (/= Just src) . gtSrc <$> (readFile dst >>= ioFlushLst)
          `orIO`
          isOldThanSomeOf dst [ src ] )
      (readFile src >>= writeFile dst . (hdr src ++ ) >> return True)
      (                                                  return False)
  where
  ioFlushLst lst = const lst <$> putStr (take (length lst - length lst) "dummy")
  infixr 2 `orIO`
  orIO p1 p2     = do { b1 <- p1; b2 <- unsafeInterleaveIO p2; return $ b1 || b2 }

ghcMake :: String -> FilePath -> IO ExitCode
ghcMake exe dir = do
  let errFile = exe ++ ".error"
  ret <- bracket (openFile errFile WriteMode) hClose $ \errH ->
           runProcess "ghc" [ "--make", exe ] (Just dir)
                      Nothing Nothing Nothing (Just errH) >>= waitForProcess
  case ret of
       ExitSuccess -> return ()
       _           -> readFile errFile >>= putStr
  return ret