[commit: testsuite] master: make it optional to have DynamicByDefault, to support older GHCs (65ab228)

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 "" = ""