Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge pull request #12 from mgajda/master

Forwarding of GHC runtime system options (useful for profiling)
  • Loading branch information...
commit 7d044d0df96ec55cbe409d923eb6e94c3faaef5c 2 parents 54d3318 + 4fcc1ba
@willdonnelly authored
View
42 Config/Dyre.hs
@@ -99,11 +99,13 @@ import System.IO ( hPutStrLn, stderr )
import System.Directory ( doesFileExist, removeFile, canonicalizePath
, getDirectoryContents, doesDirectoryExist )
import System.FilePath ( (</>) )
-import System.Environment ( getArgs )
+import System.Environment (getArgs)
+import GHC.Environment (getFullArgs)
+import Control.Exception (assert)
import Control.Monad ( when, filterM )
-import Config.Dyre.Params ( Params(..) )
+import Config.Dyre.Params ( Params(..), RTSOptionHandling(..) )
import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString )
import Config.Dyre.Compat ( customExec )
import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug
@@ -124,6 +126,8 @@ defaultParams = Params
, ghcOpts = []
, forceRecomp = True
, statusOut = hPutStrLn stderr
+ , rtsOptsHandling = RTSAppend []
+ , includeCurrentDirectory = True
}
-- | 'wrapMain' is how Dyre recieves control of the program. It is expected
@@ -183,10 +187,11 @@ wrapMain params@Params{projectName = pName} cfg = withDyreOptions params $
else enterMain errorData
where launchSub errorData tempBinary = do
statusOut params $ "Launching custom binary " ++ tempBinary ++ "\n"
+ givenArgs <- handleRTSOptions $ rtsOptsHandling params
-- Deny reconfiguration if a compile already failed.
- arguments <- case errorData of
- Nothing -> getArgs
- Just _ -> ("--deny-reconf":) `fmap` getArgs
+ let arguments = case errorData of
+ Nothing -> givenArgs
+ Just _ -> "--deny-reconf":givenArgs
-- Execute
customExec tempBinary $ Just arguments
enterMain errorData = do
@@ -209,3 +214,30 @@ recFiles d = do
subfiles <- concat `fmap` mapM recFiles dirs
return $ files ++ subfiles
else return []
+
+assertM b = assert b $ return ()
+
+-- | Filters GHC runtime system arguments:
+filterRTSArgs = filt False
+ where
+ filt _ [] = []
+ filt _ ("--RTS":rest) = []
+ filt False ("+RTS" :rest) = filt True rest
+ filt True ("-RTS" :rest) = filt False rest
+ filt False (_ :rest) = filt False rest
+ filt True (arg :rest) = arg:filt True rest
+ --filt state args = error $ "Error filtering RTS arguments in state " ++ show state ++ " remaining arguments: " ++ show args
+
+editRTSOptions opts (RTSReplace ls) = ls
+editRTSOptions opts (RTSAppend ls) = opts ++ ls
+
+handleRTSOptions h = do fargs <- getFullArgs
+ args <- getArgs
+ let rtsArgs = editRTSOptions (filterRTSArgs fargs) h
+ assertM $ not $ "--RTS" `elem` rtsArgs
+ case rtsArgs of
+ [] -> if not $ "+RTS" `elem` args
+ then return args -- cleaner output
+ else return $ "--RTS":args
+ _ -> return $ ["+RTS"] ++ rtsArgs ++ ["--RTS"] ++ args
+
View
8 Config/Dyre/Compile.hs
@@ -59,13 +59,17 @@ customCompile params@Params{statusOut = output} = do
-- | Assemble the arguments to GHC so everything compiles right.
makeFlags :: Params cfgType -> FilePath -> FilePath -> FilePath
-> FilePath -> IO [String]
-makeFlags Params{ghcOpts = flags, hidePackages = hides, forceRecomp = force}
+makeFlags Params{ghcOpts = flags, hidePackages = hides, forceRecomp = force, includeCurrentDirectory = includeCurDir}
cfgFile tmpFile cacheDir libsDir = do
currentDir <- getCurrentDirectory
- return . concat $ [ ["-v0", "-i" ++ currentDir, "-i" ++ libsDir]
+ return . concat $ [ ["-v0", "-i" ++ libsDir]
+ , if includeCurDir
+ then ["-i" ++ currentDir]
+ else []
, ["-outputdir", cacheDir]
, prefix "-hide-package" hides, flags
, ["--make", cfgFile, "-o", tmpFile]
, ["-fforce-recomp" | force] -- Only if force is true
]
where prefix y = concatMap $ \x -> [y,x]
+
View
12 Config/Dyre/Params.hs
@@ -3,7 +3,7 @@ Defines the 'Params' datatype which Dyre uses to define all
program-specific configuration data. Shouldn't be imported
directly, as 'Config.Dyre' re-exports it.
-}
-module Config.Dyre.Params ( Params(..) ) where
+module Config.Dyre.Params ( Params(..), RTSOptionHandling(..) ) where
-- | This structure is how all kinds of useful data is fed into Dyre. Of
-- course, only the 'projectName', 'realMain', and 'showError' fields
@@ -43,4 +43,14 @@ data Params cfgType = Params
-- when Dyre recompiles or launches anything. A good value
-- is 'hPutStrLn stderr', assuming there is no pressing
-- reason to not put messages on stderr.
+ , rtsOptsHandling :: RTSOptionHandling
+ -- ^ Whether to append, or replace GHC runtime system options
+ -- with others.
+ , includeCurrentDirectory :: Bool
+ -- ^ Whether to add current directory to include list (set False to
+ -- prevent name shadowing within project directory.) --
}
+
+data RTSOptionHandling = RTSReplace [String] -- replaces RTS options with given list
+ | RTSAppend [String] -- merges given list with RTS options from command line (so that nothing is lost)
+
View
2  dyre.cabal
@@ -1,5 +1,5 @@
name: dyre
-version: 0.8.7
+version: 0.8.8
category: Development, Configuration
synopsis: Dynamic reconfiguration in Haskell
Please sign in to comment.
Something went wrong with that request. Please try again.