Pattern match on an OS datatype rather than using ifdef everywhere

Cabal.cabal

@@ -70,6 +70,7 @@ Library {
         Distribution.Simple.SetupWrapper,
         Distribution.Simple.SrcDist,
         Distribution.Simple.Utils,
+        Distribution.System,
         Distribution.Verbosity,
         Distribution.Version,
         Distribution.Compat.ReadP,

Distribution/Program.hs

@@ -71,6 +71,7 @@ module Distribution.Program(
 import qualified Distribution.Compat.Map as Map
 import Distribution.Compat.Directory (findExecutable)
 import Distribution.Simple.Utils (die, rawSystemExit, rawSystemStdout)
+import Distribution.System
 import Distribution.Version (Version, readVersion)
 import Distribution.Verbosity
 import System.Directory (doesFileExist)
@@ -261,11 +262,11 @@ greencardProgram :: Program
 greencardProgram = simpleProgram "greencard"
 
 ldProgram :: Program
-#if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS)
-ldProgram = Program "ld" "ld" [] (FoundOnSystem "<what-your-hs-compiler-shipped-with>")
-#else
-ldProgram = simpleProgram "ld"
-#endif
+ldProgram = case os of
+                Windows MingW ->
+                    Program "ld" "ld" Nothing []
+                        (FoundOnSystem "<what-your-hs-compiler-shipped-with>")
+                _ -> simpleProgram "ld"
 
 tarProgram :: Program
 tarProgram = simpleProgram "tar"

Distribution/Simple/Build.hs

@@ -65,6 +65,7 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Configure
 				( localBuildInfoFile )
 import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, die )
+import Distribution.System
 
 import System.FilePath          ( (</>), pathSeparator )
 
@@ -242,11 +243,14 @@ buildPathsModule pkg_descr lbi =
 	mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel
 	mkGetDir dir Nothing       = "return " ++ show dir
 
-#if mingw32_HOST_OS
-	absolute = hasLibs pkg_descr || flat_bindirrel == Nothing
-#else
-	absolute = hasLibs pkg_descr || flat_progdirrel == Nothing || not isHugs
-#endif
+        absolute = case os of
+                       Windows MingW ->
+                           hasLibs pkg_descr ||
+                           flat_bindirrel == Nothing
+                       _ ->
+                           hasLibs pkg_descr ||
+                           flat_progdirrel == Nothing ||
+                           not isHugs
 
   	paths_modulename = autogenModuleName pkg_descr
 	paths_filename = paths_modulename ++ ".hs"
@@ -319,18 +323,14 @@ filename_stuff =
   "      _                            -> path1\n"++
   "\n"++
   "pathSeparator :: Char\n"++
-#if mingw32_HOST_OS
-  "pathSeparator = '\\\\'\n"++
-#else
-  "pathSeparator = '/'\n"++
-#endif
+  (case os of
+       Windows _ -> "pathSeparator = '\\\\'\n"
+       _         -> "pathSeparator = '/'\n") ++
   "\n"++
   "isPathSeparator :: Char -> Bool\n"++
-#if mingw32_HOST_OS
-  "isPathSeparator c = c == '/' || c == '\\\\'\n"
-#else
-  "isPathSeparator c = c == '/'\n"
-#endif
+  (case os of
+       Windows _ -> "isPathSeparator c = c == '/' || c == '\\\\'\n"
+       _         -> "isPathSeparator c = c == '/'\n")
 
 -- ------------------------------------------------------------
 -- * Testing

Distribution/Simple/Configure.hs

@@ -67,6 +67,7 @@ module Distribution.Simple.Configure (configure,
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Register (removeInstalledConfig)
 import Distribution.Setup(ConfigFlags(..), CopyDest(..))
+import Distribution.System
 import Distribution.Compiler(CompilerFlavor(..), Compiler(..),
 			     compilerVersion, compilerPath, compilerPkgToolPath,
 			     extensionsToFlags)
@@ -78,7 +79,7 @@ import Distribution.PackageDescription(
         finalizePackageDescription,
         HookedBuildInfo, sanityCheckPackage, updatePackageDescription,
 	BuildInfo(..), Executable(..), setupMessage,
-        satisfyDependency)
+        satisfyDependency, hasLibs)
 import Distribution.Simple.Utils (die, warn, rawSystemStdout)
 import Distribution.Version (Version(..), Dependency(..), VersionRange(ThisVersion),
 			     showVersion, showVersionRange)
@@ -113,10 +114,6 @@ import Distribution.Compat.ReadP
 import Distribution.Compat.Directory (createDirectoryIfMissing)
 import Prelude hiding (catch)
 
-#ifdef mingw32_HOST_OS
-import Distribution.PackageDescription (hasLibs)
-#endif
-
 #ifdef DEBUG
 import Test.HUnit
 #endif
@@ -316,23 +313,15 @@ messageDir :: PackageDescription -> LocalBuildInfo -> String
 	-> (PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath)
 	-> (PackageDescription -> LocalBuildInfo -> CopyDest -> Maybe FilePath)
 	-> IO ()
-messageDir pkg_descr lbi name mkDir
-#if mingw32_HOST_OS
-                                    mkDirRel
-#else
-                                    _
-#endif
+messageDir pkg_descr lbi name mkDir mkDirRel
  = message (name ++ " installed in: " ++ mkDir pkg_descr lbi NoCopyDest ++ rel_note)
   where
-#if mingw32_HOST_OS
-    rel_note
-      | not (hasLibs pkg_descr) &&
-        mkDirRel pkg_descr lbi NoCopyDest == Nothing
-                  = "  (fixed location)"
-      | otherwise = ""
-#else
-    rel_note      = ""
-#endif
+    rel_note = case os of
+                   Windows MingW
+                    | not (hasLibs pkg_descr) &&
+                      mkDirRel pkg_descr lbi NoCopyDest == Nothing
+                     -> "  (fixed location)"
+                   _ -> ""
 
 -- |Converts build dependencies to a versioned dependency.  only sets
 -- version information for exact versioned dependencies.

Distribution/Simple/GHC.hs

@@ -76,6 +76,7 @@ import Distribution.Version	( Version(..) )
 import qualified Distribution.Simple.GHCPackageConfig as GHC
 				( localPackageConfig,
 				  canReadLocalPackageConfig )
+import Distribution.System
 import Distribution.Verbosity
 import Language.Haskell.Extension (Extension(..))
 
@@ -271,14 +272,11 @@ build pkg_descr lbi verbosity = do
 
             runAr = rawSystemProgramConf verbosity "ar" (withPrograms lbi)
 
-#if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS)
-            rawSystemLd = rawSystemExit
-            maxCommandLineSize = 30 * 1024
-#else
-            rawSystemLd = rawSystemPathExit
+            rawSystemLd = case os of
+                              Windows MingW -> rawSystemExit
+                              _             -> rawSystemPathExit
              --TODO: discover this at configure time on unix
             maxCommandLineSize = 30 * 1024
-#endif
 
         ifVanillaLib False $ xargs maxCommandLineSize
           runAr arArgs arObjArgs
@@ -430,22 +428,18 @@ mkGHCiLibName pref lib = pref </> ("HS" ++ lib) <.> ".o"
 
 
 findLdProgram :: LocalBuildInfo -> IO FilePath
-#if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS)
-findLdProgram lbi =
-   let
-    compilerDir = takeDirectory $ compilerPath (compiler lbi)
-    baseDir     = takeDirectory compilerDir
-    binInstallLd     = baseDir </> "gcc-lib" </> "ld.exe"
-   in do
-   mb <- lookupProgram "ld" (withPrograms lbi)
-   case fmap programLocation mb of
-    Just (UserSpecified s) -> return s
-          -- assume we're using an installed copy of GHC..
-    _ -> return binInstallLd
-#else
-findLdProgram _ =
-    return "ld"
-#endif
+findLdProgram lbi
+ = case os of
+       Windows MingW ->
+           do let compilerDir = takeDirectory $ compilerPath (compiler lbi)
+                  baseDir     = takeDirectory compilerDir
+                  binInstallLd     = baseDir </> "gcc-lib" </> "ld.exe"
+              mb <- lookupProgram "ld" (withPrograms lbi)
+              case fmap programLocation mb of
+                  Just (UserSpecified s) -> return s
+                  -- assume we're using an installed copy of GHC..
+                  _ -> return binInstallLd
+       _ -> return "ld"
 
 -- -----------------------------------------------------------------------------
 -- Building a Makefile

Distribution/Simple/Hugs.hs

@@ -66,6 +66,7 @@ import Distribution.Compat.Directory
 				( copyFile, removeDirectoryRecursive )
 import System.FilePath        	( (</>), takeExtension, (<.>),
                                   searchPathSeparator, normalise, takeDirectory )
+import Distribution.System
 import Distribution.Verbosity
 import Distribution.Package	( PackageIdentifier(..) )
 
@@ -343,17 +344,18 @@ install verbosity libDir installProgDir binDir targetProgDir buildPref pkg_descr
         -- FIX (HUGS): use extensions, and options from file too?
         -- see http://hackage.haskell.org/trac/hackage/ticket/43
         let hugsOptions = hcOptions Hugs (options (buildInfo exe))
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-        let exeFile = binDir </> exeName exe <.> ".bat"
-        let script = unlines [
-                "@echo off",
-                unwords ("runhugs" : hugsOptions ++ [targetName, "%*"])]
-#else
-        let exeFile = binDir </> exeName exe
-        let script = unlines [
-                "#! /bin/sh",
-                unwords ("runhugs" : hugsOptions ++ [targetName, "\"$@\""])]
-#endif
+        let exeFile = case os of
+                          Windows _ -> binDir </> exeName exe <.> ".bat"
+                          _         -> binDir </> exeName exe
+        let script = case os of
+                         Windows _ ->
+                             let args = hugsOptions ++ [targetName, "%*"]
+                             in unlines ["@echo off",
+                                         unwords ("runhugs" : args)]
+                         _ ->
+                             let args = hugsOptions ++ [targetName, "\"$@\""]
+                             in unlines ["#! /bin/sh",
+                                         unwords ("runhugs" : args)]
         writeFile exeFile script
         perms <- getPermissions exeFile
         setPermissions exeFile perms { executable = True, readable = True }

Distribution/Simple/LocalBuildInfo.hs

@@ -73,6 +73,7 @@ import Distribution.PackageDescription (PackageDescription(..))
 import Distribution.Package (PackageIdentifier(..), showPackageId)
 import Distribution.Compiler (Compiler(..), CompilerFlavor(..), showCompilerId)
 import Distribution.Setup (CopyDest(..))
+import Distribution.System
 import Distribution.Version (showVersion)
 import System.FilePath
 #if mingw32_HOST_OS || mingw32_TARGET_OS
@@ -222,35 +223,29 @@ foreign import stdcall unsafe "shlobj.h SHGetFolderPathA"
 #endif
 
 default_bindir :: FilePath
-default_bindir = "$prefix" </>
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-	"Haskell" </> "bin"
-#else
-	"bin"
-#endif
+default_bindir = "$prefix" </> path
+    where path = case os of
+                     Windows _ -> "Haskell" </> "bin"
+                     _         -> "bin"
 
 default_libdir :: Compiler -> FilePath
-default_libdir _ = "$prefix" </>
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-                 "Haskell"
-#else
-                 "lib"
-#endif
+default_libdir _ = "$prefix" </> path
+    where path = case os of
+                     Windows _ -> "Haskell"
+                     _         -> "lib"
 
 default_libsubdir :: Compiler -> FilePath
 default_libsubdir hc =
   case compilerFlavor hc of
-	Hugs -> "hugs" </> "packages" </> "$pkg"
+        Hugs -> "hugs" </> "packages" </> "$pkg"
         JHC  -> "$compiler"
-	_    -> "$pkgid" </> "$compiler"
+        _    -> "$pkgid" </> "$compiler"
 
 default_libexecdir :: FilePath
-default_libexecdir = "$prefix" </>
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-	"$pkgid"
-#else
-	"libexec"
-#endif
+default_libexecdir = "$prefix" </> path
+    where path = case os of
+                     Windows _ -> "$pkgid"
+                     _         -> "libexec"
 
 default_datadir :: PackageDescription -> IO FilePath
 #if mingw32_HOST_OS || mingw32_TARGET_OS
@@ -333,18 +328,7 @@ absolutePath pkg_descr lbi copydest s =
   case copydest of
     NoCopyDest   -> substDir (package pkg_descr) lbi s
     CopyPrefix d -> substDir (package pkg_descr) lbi{prefix=d} s
-    CopyTo     p -> p </> (dropAbsolutePrefix (substDir (package pkg_descr) lbi s))
- where 
-   -- | If the function is applied to an absolute path then it returns a local path droping
-   -- the absolute prefix in the path. Under Windows the prefix is \"\\\", \"c:\" or \"c:\\\". Under
-   -- Unix the prefix is always \"\/\".
-   dropAbsolutePrefix :: FilePath -> FilePath
-   dropAbsolutePrefix (c:cs) | isPathSeparator c = cs
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-   dropAbsolutePrefix (_:':':c:cs) | isPathSeparator c = cs  -- path with drive letter
-   dropAbsolutePrefix (_:':':cs)                       = cs
-#endif
-   dropAbsolutePrefix cs = cs
+    CopyTo     p -> p </> (dropDrive (substDir (package pkg_descr) lbi s))
 
 substDir :: PackageIdentifier -> LocalBuildInfo -> String -> String
 substDir pkgId lbi xs = loop xs

Distribution/Simple/Register.hs

@@ -81,6 +81,7 @@ import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
 import Distribution.Simple.GHCPackageConfig (mkGHCPackageConfig, showGHCPackageConfig)
 import qualified Distribution.Simple.GHCPackageConfig
     as GHC (localPackageConfig, canWriteLocalPackageConfig, maybeCreateLocalPackageConfig)
+import Distribution.System
 import Distribution.Compat.Directory
        (removeDirectoryRecursive,
         setPermissions, getPermissions, Permissions(executable)
@@ -100,18 +101,14 @@ import Test.HUnit (Test)
 #endif
 
 regScriptLocation :: FilePath
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-regScriptLocation = "register.bat"
-#else
-regScriptLocation = "register.sh"
-#endif
+regScriptLocation = case os of
+                        Windows _ -> "register.bat"
+                        _         -> "register.sh"
 
 unregScriptLocation :: FilePath
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-unregScriptLocation = "unregister.bat"
-#else
-unregScriptLocation = "unregister.sh"
-#endif
+unregScriptLocation = case os of
+                          Windows _ -> "unregister.bat"
+                          _         -> "unregister.sh"
 
 -- -----------------------------------------------------------------------------
 -- Registration
@@ -165,23 +162,19 @@ register pkg_descr lbi regFlags
             putStrLn ("create " ++ instConf)
           writeInstalledConfig pkg_descr lbi inplace (Just instConf)
 
-	let register_flags
-		| ghc_63_plus = "update":
-#if !(mingw32_HOST_OS || mingw32_TARGET_OS)
-		                 if genScript
-                                    then []
-                                    else 
-#endif
-                                      [instConf]
-		| otherwise   = "--update-package":
-#if !(mingw32_HOST_OS || mingw32_TARGET_OS)
-				 if genScript
-                                    then []
-                                    else
-#endif
-                                      ["--input-file="++instConf]
-        
-	let allFlags = register_flags
+        let register_flags
+                | ghc_63_plus = let conf = case os of
+                                               Windows MingW
+                                                | genScript -> []
+                                               _ ->            [instConf]
+                                in "update" : conf
+                | otherwise   = let conf = case os of
+                                               Windows MingW
+                                                | genScript -> []
+                                               _ -> ["--input-file="++instConf]
+                                in "--update-package" : conf
+
+        let allFlags = register_flags
                        ++ config_flags
                        ++ if ghc_63_plus && genScript then ["-"] else []
         let pkgTool = compilerPkgToolPath hc
@@ -374,16 +367,15 @@ rawSystemEmit :: FilePath  -- ^Script name
               -> IO ()
 rawSystemEmit _ False verbosity path args
     = rawSystemExit verbosity path args
-rawSystemEmit scriptName True _ path args = do
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-  writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
-#else
-  writeFile scriptName ("#!/bin/sh\n\n"
-                        ++ (path ++ concatMap (' ':) args)
-                        ++ "\n")
-  p <- getPermissions scriptName
-  setPermissions scriptName p{executable=True}
-#endif
+rawSystemEmit scriptName True _ path args
+ = case os of
+       Windows _ ->
+           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
+       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
+                                  ++ (path ++ concatMap (' ':) args)
+                                  ++ "\n")
+               p <- getPermissions scriptName
+               setPermissions scriptName p{executable=True}
 
 -- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x
 rawSystemPipe :: FilePath  -- ^Script location
@@ -392,18 +384,17 @@ rawSystemPipe :: FilePath  -- ^Script location
               -> FilePath  -- ^Program to run
               -> [String]  -- ^Args
               -> IO ()
-rawSystemPipe scriptName _ pipeFrom path args = do
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-  writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
-#else
-  writeFile scriptName ("#!/bin/sh\n\n"
-                        ++ "echo '" ++ escapeForShell pipeFrom
-                        ++ "' | " 
-                        ++ (path ++ concatMap (' ':) args)
-                        ++ "\n")
-  p <- getPermissions scriptName
-  setPermissions scriptName p{executable=True}
-#endif
+rawSystemPipe scriptName _ pipeFrom path args
+ = case os of
+       Windows _ ->
+           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
+       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
+                                  ++ "echo '" ++ escapeForShell pipeFrom
+                                  ++ "' | "
+                                  ++ (path ++ concatMap (' ':) args)
+                                  ++ "\n")
+               p <- getPermissions scriptName
+               setPermissions scriptName p{executable=True}
   where escapeForShell [] = []
         escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs
         escapeForShell (c   :cs) = c        : escapeForShell cs

Distribution/Simple/Utils.hs

@@ -84,6 +84,7 @@ module Distribution.Simple.Utils (
 
 import Distribution.Compat.RawSystem (rawSystem)
 import Distribution.Compat.Exception (bracket)
+import Distribution.System
 
 #if __GLASGOW_HASKELL__ >= 604
 import Control.Exception (evaluate)
@@ -470,11 +471,9 @@ findHookedPackageDesc dir = do
 -- | Extension for executable files
 -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
 exeExtension :: String
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-exeExtension = "exe"
-#else
-exeExtension = ""
-#endif
+exeExtension = case os of
+                   Windows _ -> "exe"
+                   _         -> ""
 
 -- ToDo: This should be determined via autoconf (AC_OBJEXT)
 -- | Extension for object files. For GHC and NHC the extension is @\"o\"@.
@@ -485,12 +484,9 @@ objExtension = "o"
 -- | Extension for dynamically linked (or shared) libraries
 -- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)
 dllExtension :: String
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-dllExtension = "dll"
-#else
-dllExtension = "so"
-#endif
-
+dllExtension = case os of
+                   Windows _ -> "dll"
+                   _         -> "so"
 
 -- ------------------------------------------------------------
 -- * Testing

Distribution/System.hs

+
+module Distribution.System where
+
+data OS = Linux | Windows Windows | Other String
+data Windows = MingW
+
+os :: OS
+os =
+#if defined(linux_HOST_OS)
+    Linux
+#elif defined(mingw32_HOST_OS)
+    Windows MingW
+#else
+    Other System.Info.os
+#endif
+