yi-0.4: HConf.hs
module HConf where
import Prelude hiding ( catch )
import Control.Exception (catch, bracket)
import Control.Applicative
import Control.Monad.Reader
import System.IO
import System.Info
#ifndef mingw32_HOST_OS
#ifdef darwin_HOST_OS
import System.Posix.Process
(executeFile,
getProcessStatus,
forkProcess,
exitImmediately)
#else
import System.Posix.Process (executeFile)
import Control.Exception (handle)
#endif
#endif
import System.Process
import System.Directory
import System.Exit
import System.Environment
import System.Console.GetOpt
import Data.Monoid
import System.FilePath ((</>))
{-
This module provides functions to manage Xmonad style configuration.
It takes as "parameters":
* project name
* Main function of the program. This is will take a configuration, and a state as
parameter.
* Default configuration
* A way to change the configuration to make user aware of slave-compilation errors.
This will provide:
* master main:
This is the "driver" program, that just attemps to compile ~/.project/project.hs, and exec. it.
If that fails, the default main is called.
* slave main:
Function that has to be called in the ~/.project/project.hs (provides a configurable entry point)
* restart function:
(TBD) save the state; then call master to recompile and execute the new version with the saved state.
Standard scenario:
TDB
-}
data HConf state configuration = HConf {
mainMaster :: IO (),
mainSlave :: configuration -> IO (),
restart :: state -> IO ()
}
hconfOptions :: String -> [(String, String, IO () -> IO ())]
hconfOptions projectName =
[
("recompile-force",
"Force recompile of custom " ++ projectName ++ " before starting.",
\_ -> recompile projectName True >> return ()
),
("resume",
"Resume execution of " ++ projectName ++ " from previous state",
id -- this option is actually handled by the Slave.
),
("recompile",
"Recompile custom " ++ projectName ++ " if required then exit.",
\_ -> do
recompile projectName False
exitWith ExitSuccess
)
]
getHConf :: String -> state -> (String -> IO state) -> (state -> IO String) ->
configuration -> (String -> configuration -> configuration) ->
(configuration -> state -> IO ()) ->
HConf state configuration
getHConf projectName initialState recoverState saveState defaultConfiguration showErrorsInConf realMain = HConf
{
-- The entry point into Project. Attempts to compile any custom main
-- for Project, and if it doesn't find one, just launches the default.
mainMaster = do
let launch = do
maybeErrors <- buildLaunch projectName
case maybeErrors of
Nothing -> realMain defaultConfiguration initialState
Just errors -> realMain (showErrorsInConf errors defaultConfiguration) initialState
let optDescriptions =
(flip fmap) (hconfOptions projectName) $ \(name,desc,f) ->
let apply_f_descr = NoArg (f launch)
in Option [] [name] apply_f_descr desc
args <- getArgs
let (opt_actions, _, _) = getOpt Permute optDescriptions args
sequence_ opt_actions
launch
-- @restart state@. Attempt to restart Project by executing the
-- program @projectName@.
-- This function will never return.
, restart = \state -> do
#ifndef mingw32_HOST_OS
s <- saveState state
let args = ["--resume", s]
executeFile projectName True args Nothing -- TODO: catch exceptions
-- run the master, who will take care of recompiling; handle errors, etc.
#else
return ()
#endif
-- The configurable main, callable from ~/.project/project.hs
, mainSlave = \userConfig -> do
args <- getArgs
state <- case args of
["--resume", s] -> recoverState s
_ -> return initialState
realMain userConfig state
}
-- Lift an IO action
io :: MonadIO m => IO a -> m a
io = liftIO
-- | Return the path to @~\/.Project@.
getProjectDir :: MonadIO m => String -> m String
getProjectDir projectName = io $ getAppUserDataDirectory projectName
-- | Return the full path to the errors file
getErrorsFile :: (MonadIO m, Functor m) => String -> m String
getErrorsFile projectName = do dir <- getProjectDir projectName
return $ dir </> projectName ++ ".errors"
-- | 'recompile projectName force' recompiles ~\/.Project\/Project.hs when any of the
-- following apply:
-- * force is True
-- * the Project executable does not exist
-- * the Project executable is older than Project.hs
--
-- The -i flag is used to restrict recompilation to the Project.hs file only.
--
-- Compilation errors (if any) are logged to
-- ~\/.Project\/Project.errors. If GHC indicates failure with a
-- non-zero exit code; we read the errors and return them.
--
-- Returns the errors if there were any; otherwise Nothing
--
-- Errors can be returned in any of
-- these cases:
-- * ghc missing
-- * ~\/.Project\/Project.hs missing
-- * Project.hs fails to compile
-- ** wrong ghc in path (fails to compile)
-- ** type error, syntax error, ..
-- * Missing Project dependency packages
--
recompile :: MonadIO m => String -> Bool -> m (Maybe String)
recompile projectName force = io $ do
dir <- getProjectDir projectName
let binn = projectName ++ "-"++arch++"-"++os
bin = dir ++ "/" ++ binn
base = dir ++ "/" ++ projectName
err = base ++ ".errors"
src = base ++ ".hs"
srcT <- getModTime src
binT <- getModTime bin
if (force || srcT > binT)
then do
if force
then putStrLn $ "Forcing recompile of custom " ++ projectName
else putStrLn $ "Recompiling custom " ++ projectName
status <- bracket (openFile err WriteMode) hClose $ \h -> do
-- note that since we checked for recompilation ourselves,
-- we disable ghc recompilaton checks.
waitForProcess =<< runProcess "ghc" ["--make", projectName ++ ".hs", "-i", "-fforce-recomp", "-v0", "-o",binn,"-threaded"] (Just dir)
Nothing Nothing Nothing (Just h)
-- now, if it fails, run xmessage to let the user know:
if status /= ExitSuccess
then do
ghcErr <- readFile err
let msg = unlines $
["Error detected while loading " ++ projectName ++ " configuration file: " ++ src]
++ lines ghcErr ++ ["","Please check the file for errors."]
return $ Just msg
else return Nothing
else return Nothing
where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing)
-- | Launch the custom (slave) program.
-- Call @recompile False@
-- If there is a slave to run, this function does not return.
-- If there are errors and the function returns, they are returned in a string;
-- If there are errors and the slave is run, we pass the error file as an argument to it.
buildLaunch :: String -> IO (Maybe String)
buildLaunch projectName = do
#ifndef mingw32_HOST_OS
errMsg <- recompile projectName False
dir <- getProjectDir projectName
args <- getArgs
args' <- case errMsg of
Nothing -> return args
Just _ -> do errFile <- getErrorsFile projectName
return (args ++ [errFile])
let executable_file = projectName ++ "-" ++ arch ++ "-" ++ os
executable_path = dir </> executable_file
putStrLn $ "Launching custom " ++ projectName ++ ": " ++ show executable_path
#ifndef darwin_HOST_OS
handle (\_exception -> return ())
(executeFile executable_path False args' Nothing)
return $ Just
("Custom " ++ projectName
++ " (" ++ show executable_path ++ ") "
++ "could not be launched!\n") `mappend` errMsg
#else
-- Darwin is odd or broken; Take your pick. According to:
-- http://uninformed.org/index.cgi?v=1&a=1&p=16
-- and
-- http://www.cherrypy.org/ticket/581
-- In order to get around a "Operation not supported" error on execv[e] it's
-- required to fork THEN execv[e]. - coconnor
child_pid <- forkProcess $ executeFile executable_path False args' Nothing
child_status <- getProcessStatus True False child_pid
case child_status of
Nothing -> return $ Just
("Custom " ++ projectName
++ " (" ++ show executable_path ++ ") "
++ "could not be launched!\n") `mappend` errMsg
Just _ -> do
exitImmediately ExitSuccess
return Nothing
#endif
#else
return Nothing
#endif