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.

1 files changed, 40 insertions, 24 deletions

diff --git a/testsuite/mk/ghc-config.hs b/testsuite/mk/ghc-config.hs
index 77efbcd95c..b667b84d66 100644
--- a/testsuite/mk/ghc-config.hs
+++ b/testsuite/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 "" = ""