diff --git a/Config/Dyre.hs b/Config/Dyre.hs --- a/Config/Dyre.hs +++ b/Config/Dyre.hs @@ -99,11 +99,13 @@ 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 @@ , 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 @@ 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 @@ 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 + diff --git a/Config/Dyre/Compile.hs b/Config/Dyre/Compile.hs --- a/Config/Dyre/Compile.hs +++ b/Config/Dyre/Compile.hs @@ -59,13 +59,17 @@ -- | 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] + diff --git a/Config/Dyre/Options.hs b/Config/Dyre/Options.hs --- a/Config/Dyre/Options.hs +++ b/Config/Dyre/Options.hs @@ -17,7 +17,8 @@ preserves the important flags with a call to 'customOptions'. -} module Config.Dyre.Options - ( withDyreOptions + ( removeDyreOptions + , withDyreOptions , customOptions , getDenyReconf , getForceReconf @@ -34,6 +35,11 @@ import Config.Dyre.Params +-- | Remove all Dyre's options from the given commandline arguments. +removeDyreOptions :: [String] -> [String] +removeDyreOptions = filter $ not . prefixElem dyreArgs + where prefixElem xs = or . zipWith ($) (map isPrefixOf xs) . repeat + -- | Store Dyre's command-line options to the IO-Store "dyre", -- and then execute the provided IO action with all Dyre's -- options removed from the command-line arguments. @@ -57,9 +63,7 @@ putValue "dyre" "debugMode" $ "--dyre-debug" `elem` args -- We filter the arguments, so now Dyre's arguments 'vanish' - withArgs (filterArgs args) action - where filterArgs = filter $ not . prefixElem dyreArgs - prefixElem xs = or . zipWith ($) (map isPrefixOf xs) . repeat + withArgs (removeDyreOptions args) action -- | Get the value of the '--force-reconf' flag, which is used -- to force a recompile of the custom configuration. @@ -106,13 +110,13 @@ Nothing -> getArgs Just oa -> return oa -- Combine the other arguments with the Dyre-specific ones - let args = filter (not . null) $ - mainArgs ++ [ if debugMode then "--dyre-debug" else "" - , case stateFile of - Nothing -> "" - Just sf -> "--dyre-state-persist=" ++ sf - , "--dyre-master-binary=" ++ fromJust masterPath - ] + let args = mainArgs ++ (filter (not . null) $ + [ if debugMode then "--dyre-debug" else "" + , case stateFile of + Nothing -> "" + Just sf -> "--dyre-state-persist=" ++ sf + , "--dyre-master-binary=" ++ fromJust masterPath + ]) return args -- | Look for the given flag in the argument array, and store diff --git a/Config/Dyre/Params.hs b/Config/Dyre/Params.hs --- a/Config/Dyre/Params.hs +++ b/Config/Dyre/Params.hs @@ -3,7 +3,7 @@ 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 @@ -- 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) + diff --git a/Tests/allTests.sh b/Tests/allTests.sh --- a/Tests/allTests.sh +++ b/Tests/allTests.sh @@ -6,6 +6,7 @@ cd $TESTDIR TEST_RESULT=`./runTest.sh` if [ "$TEST_RESULT" != 'Passed' ]; then + echo "$TEST_RESULT" echo "$TEST_RESULT in test $TESTDIR" rm -r working exit 1 diff --git a/Tests/basic/runTest.sh b/Tests/basic/runTest.sh --- a/Tests/basic/runTest.sh +++ b/Tests/basic/runTest.sh @@ -21,7 +21,7 @@ ### TEST A ### cp ../BasicTest.hs ../Main.hs . -ghc --make Main.hs -o basic 2> /dev/null +ghc --make Main.hs -o basic > /dev/null 2>&1 OUTPUT_A=`./basic --dyre-debug` assert "$OUTPUT_A" "Basic Test Version 1.0 - 3" "A" diff --git a/Tests/config-check/runTest.sh b/Tests/config-check/runTest.sh --- a/Tests/config-check/runTest.sh +++ b/Tests/config-check/runTest.sh @@ -18,7 +18,7 @@ ### TEST A ### cp ../ConfigCheckTest.hs ../Main.hs . cp ../configCheckTestA.hs ./configCheckTest.hs -ghc --make Main.hs -o configCheck 2> /dev/null +ghc --make Main.hs -o configCheck > /dev/null 2>&1 OUTPUT_A=`./configCheck --dyre-debug` assert "$OUTPUT_A" "custom-a" "A" diff --git a/Tests/recompile-relaunch/runTest.sh b/Tests/recompile-relaunch/runTest.sh --- a/Tests/recompile-relaunch/runTest.sh +++ b/Tests/recompile-relaunch/runTest.sh @@ -17,7 +17,7 @@ ### TEST A ### cp ../RecompileRelaunchTest.hs ../Main.hs ../recompileRelaunchTest.hs . -ghc --make Main.hs -o recompileRelaunch 2> /dev/null +ghc --make Main.hs -o recompileRelaunch > /dev/null 2>&1 OUTPUT_A=`./recompileRelaunch --dyre-debug --deny-reconf` assert "$OUTPUT_A" "Testing....Successful" "A" diff --git a/dyre.cabal b/dyre.cabal --- a/dyre.cabal +++ b/dyre.cabal @@ -1,5 +1,5 @@ name: dyre -version: 0.8.7 +version: 0.8.8 category: Development, Configuration synopsis: Dynamic reconfiguration in Haskell