Commit 53277279 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Pattern match on an OS datatype rather than using ifdef everywhere

parent 8742ba8e
......@@ -70,6 +70,7 @@ Library {
Distribution.Simple.SetupWrapper,
Distribution.Simple.SrcDist,
Distribution.Simple.Utils,
Distribution.System,
Distribution.Verbosity,
Distribution.Version,
Distribution.Compat.ReadP,
......
......@@ -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"
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment