Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
http://hackage.haskell.org/trac/ghc/changeset/65ab2281b3a3024220d02a8aa557cfe5a4cba118 >--------------------------------------------------------------- commit 65ab2281b3a3024220d02a8aa557cfe5a4cba118 Author: Simon Marlow <[email protected]> Date: Mon Oct 29 10:37:31 2012 +0000 make it optional to have DynamicByDefault, to support older GHCs It's often useful to be able to say 'make TEST_HC=ghc' to check that a test really fails with a different GHC. >--------------------------------------------------------------- mk/ghc-config.hs | 64 +++++++++++++++++++++++++++++++++-------------------- 1 files changed, 40 insertions(+), 24 deletions(-) diff --git a/mk/ghc-config.hs b/mk/ghc-config.hs index 77efbcd..b667b84 100644 --- a/mk/ghc-config.hs +++ b/mk/ghc-config.hs @@ -7,22 +7,22 @@ main = do info <- readProcess ghc ["+RTS", "--info"] "" let fields = read info :: [(String,String)] - getGhcField fields "HostOS" "Host OS" - getGhcField fields "WORDSIZE" "Word size" - getGhcField fields "TARGETPLATFORM" "Target platform" - getGhcField fields "TargetOS_CPP" "Target OS" - getGhcField fields "TargetARCH_CPP" "Target architecture" + getGhcFieldOrFail fields "HostOS" "Host OS" + getGhcFieldOrFail fields "WORDSIZE" "Word size" + getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" + getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" + getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" info <- readProcess ghc ["--info"] "" let fields = read info :: [(String,String)] - getGhcField fields "GhcStage" "Stage" - getGhcField fields "GhcWithNativeCodeGen" "Have native code generator" - getGhcField fields "GhcWithInterpreter" "Have interpreter" - getGhcField fields "GhcUnregisterised" "Unregisterised" - getGhcField fields "GhcWithSMP" "Support SMP" - getGhcField fields "GhcRTSWays" "RTS ways" - getGhcField fields "GhcDynamicByDefault" "Dynamic by default" + getGhcFieldOrFail fields "GhcStage" "Stage" + getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator" + getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter" + getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised" + getGhcFieldOrFail fields "GhcWithSMP" "Support SMP" + getGhcFieldOrFail fields "GhcRTSWays" "RTS ways" + getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO" getGhcFieldProgWithDefault fields "AR" "ar command" "ar" let pkgdb_flag = case lookup "Project version" fields of @@ -32,20 +32,36 @@ main = do putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag -getGhcField :: [(String,String)] -> String -> String -> IO () -getGhcField fields mkvar key = - case lookup key fields of - Nothing -> fail ("No field: " ++ key) - Just val -> putStrLn (mkvar ++ '=':val) +getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO () +getGhcFieldOrFail fields mkvar key + = getGhcField fields mkvar key id (fail ("No field: " ++ key)) + +getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO () +getGhcFieldOrDefault fields mkvar key deflt + = getGhcField fields mkvar key id on_fail + where + on_fail = putStrLn (mkvar ++ '=' : deflt) + +getGhcFieldProgWithDefault + :: [(String,String)] + -> String -> String -> String + -> IO () +getGhcFieldProgWithDefault fields mkvar key deflt + = getGhcField fields mkvar key fix on_fail + where + fix val = fixSlashes (fixTopdir topdir val) + topdir = fromMaybe "" (lookup "LibDir" fields) + on_fail = putStrLn (mkvar ++ '=' : deflt) -getGhcFieldProgWithDefault :: [(String,String)] - -> String -> String -> String -> IO () -getGhcFieldProgWithDefault fields mkvar key deflt = do +getGhcField + :: [(String,String)] -> String -> String + -> (String -> String) + -> IO () + -> IO () +getGhcField fields mkvar key fix on_fail = case lookup key fields of - Nothing -> putStrLn (mkvar ++ '=' : deflt) - Just val -> putStrLn (mkvar ++ '=' : fixSlashes (fixTopdir topdir val)) - where - topdir = fromMaybe "" (lookup "LibDir" fields) + Nothing -> on_fail + Just val -> putStrLn (mkvar ++ '=' : fix val) fixTopdir :: String -> String -> String fixTopdir t "" = "" _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
