diff --git a/Config/Dyre.hs b/Config/Dyre.hs --- a/Config/Dyre.hs +++ b/Config/Dyre.hs @@ -96,15 +96,18 @@ module Config.Dyre ( wrapMain, Params(..), defaultParams ) where import System.IO ( hPutStrLn, stderr ) -import System.Directory ( doesFileExist, removeFile, canonicalizePath ) +import System.Directory ( doesFileExist, removeFile, canonicalizePath + , getDirectoryContents, doesDirectoryExist ) +import System.FilePath ( () ) import System.Environment ( getArgs ) -import Control.Monad ( when ) +import Control.Monad ( when, filterM ) import Config.Dyre.Params ( Params(..) ) import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString ) import Config.Dyre.Compat ( customExec ) -import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug, withDyreOptions ) +import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug + , withDyreOptions ) import Config.Dyre.Paths ( getPaths, maybeModTime ) -- | A set of reasonable defaults for configuring Dyre. The fields that @@ -135,7 +138,9 @@ then realMain params cfg else do -- Get the important paths - (thisBinary, tempBinary, configFile, cacheDir) <- getPaths params + (thisBinary,tempBinary,configFile,cacheDir,libsDir) <- getPaths params + libFiles <- recFiles libsDir + libTimes <- mapM maybeModTime libFiles -- Check their modification times thisTime <- maybeModTime thisBinary @@ -148,6 +153,7 @@ -- Either the user or timestamps indicate we need to recompile let needReconf = or [ tempTime < confTime , tempTime < thisTime + , or . map (tempTime <) $ libTimes , forceReconf ] @@ -163,14 +169,17 @@ errorData <- getErrorString params customExists <- doesFileExist tempBinary - -- Canonicalize the paths for comparison to avoid symlinks throwing - -- us off. We do it here instead of earlier because canonicalizePath - -- drops path components when one of them is nonexistent. - thisBinary' <- canonicalizePath thisBinary - tempBinary' <- canonicalizePath tempBinary - - if confExists && customExists && (thisBinary' /= tempBinary') - then launchSub errorData tempBinary + if confExists && customExists + then do + -- Canonicalize the paths for comparison to avoid symlinks + -- throwing us off. We do it here instead of earlier because + -- canonicalizePath throws an exception when the file is + -- nonexistent. + thisBinary' <- canonicalizePath thisBinary + tempBinary' <- canonicalizePath tempBinary + if thisBinary' /= tempBinary' + then launchSub errorData tempBinary + else enterMain errorData else enterMain errorData where launchSub errorData tempBinary = do statusOut params $ "Launching custom binary " ++ tempBinary ++ "\n" @@ -185,9 +194,18 @@ let mainConfig = case errorData of Nothing -> cfg Just ed -> showError params cfg ed - -- Remove the error file if it exists - errorFile <- getErrorPath params - errorExists <- doesFileExist errorFile - when errorExists $ removeFile errorFile -- Enter the main program realMain params mainConfig + +recFiles :: FilePath -> IO [FilePath] +recFiles d = do + exists <- doesDirectoryExist d + if exists + then do + nodes <- getDirectoryContents d + let nodes' = map (d ) . filter (`notElem` [".", ".."]) $ nodes + files <- filterM doesFileExist nodes' + dirs <- filterM doesDirectoryExist nodes' + subfiles <- concat `fmap` mapM recFiles dirs + return $ files ++ subfiles + else return [] diff --git a/Config/Dyre/Compile.hs b/Config/Dyre/Compile.hs --- a/Config/Dyre/Compile.hs +++ b/Config/Dyre/Compile.hs @@ -19,7 +19,7 @@ -- | Return the path to the error file. getErrorPath :: Params cfgType -> IO FilePath getErrorPath params = do - (_,_,_, cacheDir) <- getPaths params + (_,_,_, cacheDir, _) <- getPaths params return $ cacheDir "errors.log" -- | If the error file exists and actually has some contents, return @@ -39,14 +39,14 @@ -- containing any compiler output. customCompile :: Params cfgType -> IO () customCompile params@Params{statusOut = output} = do - (thisBinary, tempBinary, configFile, cacheDir) <- getPaths params + (thisBinary, tempBinary, configFile, cacheDir, libsDir) <- getPaths params output $ "Configuration '" ++ configFile ++ "' changed. Recompiling." createDirectoryIfMissing True cacheDir -- Compile occurs in here errFile <- getErrorPath params result <- bracket (openFile errFile WriteMode) hClose $ \errHandle -> do - ghcOpts <- makeFlags params configFile tempBinary cacheDir + ghcOpts <- makeFlags params configFile tempBinary cacheDir libsDir ghcProc <- runProcess ghc ghcOpts (Just cacheDir) Nothing Nothing Nothing (Just errHandle) waitForProcess ghcProc @@ -57,11 +57,12 @@ else output "Program reconfiguration successful." -- | Assemble the arguments to GHC so everything compiles right. -makeFlags :: Params cfgType -> FilePath -> FilePath -> FilePath -> IO [String] +makeFlags :: Params cfgType -> FilePath -> FilePath -> FilePath + -> FilePath -> IO [String] makeFlags Params{ghcOpts = flags, hidePackages = hides, forceRecomp = force} - cfgFile tmpFile cacheDir = do + cfgFile tmpFile cacheDir libsDir = do currentDir <- getCurrentDirectory - return . concat $ [ ["-v0", "-i" ++ currentDir] + return . concat $ [ ["-v0", "-i" ++ currentDir, "-i" ++ libsDir] , ["-outputdir", cacheDir] , prefix "-hide-package" hides, flags , ["--make", cfgFile, "-o", tmpFile] diff --git a/Config/Dyre/Paths.hs b/Config/Dyre/Paths.hs --- a/Config/Dyre/Paths.hs +++ b/Config/Dyre/Paths.hs @@ -12,7 +12,7 @@ -- | Return the paths to, respectively, the current binary, the custom -- binary, the config file, and the cache directory. -getPaths :: Params c -> IO (FilePath, FilePath, FilePath, FilePath) +getPaths :: Params c -> IO (FilePath, FilePath, FilePath, FilePath, FilePath) getPaths params@Params{projectName = pName} = do thisBinary <- getExecutablePath debugMode <- getDebug @@ -26,9 +26,10 @@ (False, Nothing) -> getUserConfigDir pName (False, Just cd) -> cd let tempBinary = cacheDir pName ++ "-" ++ os ++ "-" ++ arch + <.> takeExtension thisBinary let configFile = configDir pName ++ ".hs" - - return (thisBinary, tempBinary, configFile, cacheDir) + let libsDir = configDir "lib" + return (thisBinary, tempBinary, configFile, cacheDir, libsDir) -- | Check if a file exists. If it exists, return Just the modification -- time. If it doesn't exist, return Nothing. diff --git a/dyre.cabal b/dyre.cabal --- a/dyre.cabal +++ b/dyre.cabal @@ -1,5 +1,5 @@ name: dyre -version: 0.8.5 +version: 0.8.6 category: Development, Configuration synopsis: Dynamic reconfiguration in Haskell @@ -16,7 +16,7 @@ stability: beta author: Will Donnelly maintainer: Will Donnelly -copyright: (c) 2010 Will Donnelly +copyright: (c) 2011 Will Donnelly license: BSD3 license-file: LICENSE