module GHC.ParMake.Util (runProcess, upToDateCheck
, UpToDateStatus(..)
, defaultOutputHooks, OutputHooks(..)
, warn, notice, info, debug, fatal
, warn', notice', noticeRaw, info', debug'
, Verbosity, intToVerbosity
, silent, normal, verbose, deafening)
where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Monad (forM_, when)
import qualified Control.Exception as Exception
import System.Directory (doesFileExist, getModificationTime)
import System.Exit (ExitCode(..))
import System.IO ( hClose, hGetContents, hFlush, hPutStr, hPutStrLn
, hSetBinaryMode, stderr, stdout)
import System.Process (runInteractiveProcess, waitForProcess)
import GHC.ParMake.Common (firstM)
data Verbosity = Silent | Normal | Verbose | Deafening
deriving (Show, Read, Eq, Ord, Enum, Bounded)
silent :: Verbosity
silent = Silent
normal :: Verbosity
normal = Normal
verbose :: Verbosity
verbose = Verbose
deafening :: Verbosity
deafening = Deafening
intToVerbosity :: Int -> Maybe Verbosity
intToVerbosity 0 = Just Silent
intToVerbosity 1 = Just Normal
intToVerbosity 2 = Just Verbose
intToVerbosity 3 = Just Deafening
intToVerbosity _ = Nothing
fatal :: String -> a
fatal s = error $ "ghc-parmake: " ++ s
warn :: OutputHooks -> Verbosity -> String -> IO ()
warn outHooks verbosity msg =
when (verbosity >= normal) $
putStrErrHook outHooks (wrapText ("Warning: " ++ msg))
warn' :: Verbosity -> String -> IO ()
warn' = warn defaultOutputHooks
noticeRaw :: OutputHooks -> Verbosity -> String -> IO ()
noticeRaw outHooks verbosity msg =
when (verbosity >= normal) $ do
flushStdOutHook outHooks
putStrHook outHooks msg
notice :: OutputHooks -> Verbosity -> String -> IO ()
notice h v msg = noticeRaw h v (wrapText msg)
notice' :: Verbosity -> String -> IO ()
notice' = notice defaultOutputHooks
info :: OutputHooks -> Verbosity -> String -> IO ()
info outHooks verbosity msg =
when (verbosity >= verbose) $
putStrHook outHooks (wrapText msg)
info' :: Verbosity -> String -> IO ()
info' = info defaultOutputHooks
debug :: OutputHooks -> Verbosity -> String -> IO ()
debug outHooks verbosity msg =
when (verbosity >= deafening) $ do
putStrHook outHooks (wrapText msg)
flushStdOutHook outHooks
debug' :: Verbosity -> String -> IO ()
debug' = debug defaultOutputHooks
data OutputHooks = OutputHooks {
putStrHook :: !(String -> IO ()),
putStrLnHook :: !(String -> IO ()),
putStrErrHook :: !(String -> IO ()),
putStrLnErrHook :: !(String -> IO ()),
flushStdOutHook :: !(IO ())
}
defaultOutputHooks :: OutputHooks
defaultOutputHooks = OutputHooks {
putStrHook = putStr,
putStrLnHook = putStrLn,
putStrErrHook = hPutStr stderr,
putStrLnErrHook = hPutStrLn stderr,
flushStdOutHook = hFlush stdout
}
runProcess :: OutputHooks
-> Maybe FilePath
-> FilePath
-> [String]
-> IO ExitCode
runProcess outHooks cwd path args = do
Exception.bracket
(runInteractiveProcess path args cwd Nothing)
(\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
$ \(inh,outh,errh,pid) -> do
hSetBinaryMode errh False
hClose inh
err <- hGetContents errh
out <- hGetContents outh
mvErr <- newEmptyMVar
mvOut <- newEmptyMVar
let force outputHook str = forM_ (lines str) (\l -> outputHook l)
_ <- forkIO $ force (putStrLnHook outHooks) out >> putMVar mvOut ()
_ <- forkIO $ force (putStrLnErrHook outHooks) err >> putMVar mvErr ()
_ <- takeMVar mvOut
_ <- takeMVar mvErr
exitcode <- waitForProcess pid
return exitcode
wrapText :: String -> String
wrapText = unlines
. concatMap (map unwords
. wrapLine 79
. words)
. lines
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
where wrap :: Int -> [String] -> [String] -> [[String]]
wrap 0 [] (w:ws)
| length w + 1 > width
= wrap (length w) [w] ws
wrap col line (w:ws)
| col + length w + 1 > width
= reverse line : wrap 0 [] (w:ws)
wrap col line (w:ws)
= let col' = col + length w + 1
in wrap col' (w:line) ws
wrap _ [] [] = []
wrap _ line [] = [reverse line]
data UpToDateStatus = UpToDate | TargetDoesNotExist | NewerDependency FilePath
deriving (Eq, Ord, Show)
upToDateCheck :: FilePath -> [FilePath] -> IO UpToDateStatus
upToDateCheck tId tDeps =
do tExists <- doesFileExist tId
if not tExists
then return TargetDoesNotExist
else do tModTime <- getModificationTime tId
mNewerDep <- firstM tDeps
(\d -> (> tModTime) <$> getModificationTime d)
return $ case mNewerDep of
Just d -> NewerDependency d
Nothing -> UpToDate