module HsConfigure (
runUsersEx
) where
import Control.Exception
import System.Environment (getArgs)
import System.IO (openFile, hClose, IOMode(WriteMode, AppendMode), hPrint)
import System.Directory (doesDirectoryExist, createDirectory, copyFile, doesFileExist,
getAppUserDataDirectory, getModificationTime)
import System.FilePath (splitPath)
import System.Process (runProcess, waitForProcess)
import System.Posix.Process (executeFile)
import System.Info (os, arch)
import Control.Monad (when, unless)
import Control.Exception (bracket)
import Control.Applicative ((<$>))
import Data.Version (Version, showVersion)
runUsersEx :: String -> Maybe Version -> Maybe FilePath -> IO () -> IO ()
runUsersEx prjName ver src defaultAction
= do errFile <- getAppUserDataDirectory prjName >>= return . addErrSuffix . mkBaseFile prjName
catch (buildLaunch prjName ver src) $
\(err :: IOException) -> bracket (openFile errFile AppendMode) hClose (flip hPrint err)
defaultAction
buildLaunch :: String -> Maybe Version -> Maybe FilePath -> IO ()
buildLaunch prjName ver src = do
whenMaybe src $ initAppUserDataDirectory prjName ver
recompile prjName ver
exec <- getAppUserDataDirectory prjName >>= return . addExecuteSuffix . mkBaseFile prjName
args <- getArgs
executeFile exec False args Nothing
initAppUserDataDirectory :: String -> Maybe Version -> FilePath -> IO ()
initAppUserDataDirectory prjName ver defSrc = do
dir <- getAppUserDataDirectory prjName
let src = addSrcSuffix ver $ mkBaseFile prjName dir
unlessM (doesDirectoryExist dir) $ createDirectory dir
unlessM (doesFileExist src) $ copyFile defSrc src
recompile :: String -> Maybe Version -> IO ()
recompile prjName ver = do
dir <- getAppUserDataDirectory prjName
let base = mkBaseFile prjName dir
bin = addExecuteSuffix base
src = addSrcSuffix ver base
err = addErrSuffix base
srcT <- getModTime src
binT <- getModTime bin
when (srcT > binT) $ do
bracket (openFile err WriteMode) hClose $ \h -> do
waitForProcess =<<
runProcess "ghc" ["--make", basename src, "-i", "-o", bin]
(Just dir) Nothing Nothing Nothing (Just h)
return ()
where getModTime f = catch (Just <$> getModificationTime f) (\(e :: IOException) -> return Nothing)
basename = last . splitPath
mkBaseFile :: String -> String -> String
mkBaseFile prjName = (++ "/" ++ prjName)
addExecuteSuffix, addErrSuffix :: String -> String
addSrcSuffix :: Maybe Version -> String -> String
addExecuteSuffix = (++ "-" ++ arch ++ "-" ++ os)
addErrSuffix = (++ ".error")
addSrcSuffix Nothing = (++ ".hs")
addSrcSuffix (Just v) = (++ "-" ++ showVersion v ++ ".hs")
whenMaybe :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenMaybe Nothing _ = return ()
whenMaybe (Just x) f = f x
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mp s = mp >>= flip unless s