Commit d84d3728 authored by simonmar's avatar simonmar
Browse files

Huge wad of changes from GHC team

- Rename Compat.* modules to Distribution.Compat.*
- Add {-# OPTIONS -cpp #-} to a few modules
- Distribution.Compat.ReadP: use real ReadP in GHC 6.3+
- new module: Distribution.Extension, contains Extension type
  formerly from Distribution.Misc.
- new module: Distribution.License, contains License type
  formerly from Distribution.Misc.
- remove Distribution.Misc
- new module: Distribution.ParseUtils, containing various parsing utilities
  formerly from Distribution.Package, that are re-used in 
  Distribution.InstalledPackageInfo.
- new module: Distribution.PackageDescription contains everything related
  to PackageDescription, which was formerly in Distribution.Package.
- Distribution.Package now contains only PackageId-related stuff.
- Distribution.InstalledPackageInfo: update for use in GHC, add
  parsing/pretty-printing.
- Compat.H98 is now Distribution.Compat.Error (it contained only stuff
  related to the Error monad, which isn't H98 anyway).
- remove imports of H98 libs (use hierarchical ones instead)
- configure now detects the GHC version (but doesn't do anything with it... yet)
parent 10c272e3
{-# OPTIONS -cpp #-}
module Distribution.Compat.Directory (
findExecutable, copyFile
) where
#if __GLASGOW_HASKELL__ < 603
#include "config.h"
#endif
#if __GLASGOW_HASKELL__ > 602
import System.Directory ( findExecutable, copyFile )
#else /* to end of file... */
import System.Environment ( getEnv )
import Distribution.Compat.FilePath
import System.IO
import Foreign
import System.Directory
import Distribution.Compat.Exception (bracket)
import Control.Monad (when)
import System.Posix (getFileStatus,setFileMode,fileMode,accessTime,
setFileMode,modificationTime,setFileTimes)
findExecutable :: String -> IO (Maybe FilePath)
findExecutable binary = do
path <- getEnv "PATH"
search (parseSearchPath path)
where
search :: [FilePath] -> IO (Maybe FilePath)
search [] = return Nothing
search (d:ds) = do
let path = d `joinFileName` binary `joinFileExt` exeSuffix
b <- doesFileExist path
if b then return (Just path)
else search ds
exeSuffix :: String
#ifdef mingw32_TARGET_OS
exeSuffix = "exe"
#else
exeSuffix = ""
#endif
copyPermissions :: FilePath -> FilePath -> IO ()
#ifndef mingw32_TARGET_OS
copyPermissions src dest
= do srcStatus <- getFileStatus src
setFileMode dest (fileMode srcStatus)
#else
copyPermissions src dest
= getPermissions src >>= setPermissions dest
#endif
copyFileTimes :: FilePath -> FilePath -> IO ()
#ifndef mingw32_TARGET_OS
copyFileTimes src dest
= do st <- getFileStatus src
let atime = accessTime st
mtime = modificationTime st
setFileTimes dest atime mtime
#else
copyFileTimes src dest
= return ()
#endif
-- |Preserves permissions and, if possible, atime+mtime
copyFile :: FilePath -> FilePath -> IO ()
copyFile src dest
| dest == src = fail "copyFile: source and destination are the same file"
#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
| otherwise = do readFile src >>= writeFile dest
try (copyPermissions src dest)
return ()
#else
| otherwise = bracket (openBinaryFile src ReadMode) hClose $ \hSrc ->
bracket (openBinaryFile dest WriteMode) hClose $ \hDest ->
do allocaBytes bufSize $ \buffer -> copyContents hSrc hDest buffer
try (copyPermissions src dest)
try (copyFileTimes src dest)
return ()
where bufSize = 1024
copyContents hSrc hDest buffer
= do count <- hGetBuf hSrc buffer bufSize
when (count > 0) $ do hPutBuf hDest buffer count
copyContents hSrc hDest buffer
#endif
#endif
{-# OPTIONS -cpp #-}
module Compat.H98 (Error(..)) where
module Distribution.Compat.Error (Error(..)) where
#ifndef __NHC__
import Control.Monad.Error (Error(..))
......
{-# OPTIONS -cpp #-}
module Compat.Exception (bracket) where
module Distribution.Compat.Exception (bracket,finally) where
#ifdef __NHC__
import System.IO.Error (catch, ioError)
#else
import Control.Exception (bracket)
import Control.Exception (bracket,finally)
#endif
#ifdef __NHC__
......@@ -15,4 +15,7 @@ bracket before after thing
ioError e
after a
return r
finally :: IO a -> IO b -> IO a
finally thing after = bracket (return ()) (const after) thing
#endif
{-# OPTIONS -cpp #-}
module Compat.RawSystem (rawSystem) where
module Distribution.Compat.RawSystem (rawSystem) where
#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
import Data.List (intersperse)
......
{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.ReadP
-- Module : Distribution.Compat.ReadP
-- Copyright : (c) The University of Glasgow 2002
-- License : BSD-style (see the file libraries/base/LICENSE)
--
......@@ -19,9 +20,10 @@
--
-- This version of ReadP has been locally hacked to make it H98, by
-- Martin Sjögren <msjogren@gmail.com>
--
-----------------------------------------------------------------------------
module Compat.ReadP
module Distribution.Compat.ReadP
(
-- * The 'ReadP' type
ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
......@@ -63,13 +65,24 @@ module Compat.ReadP
-- * Running a parser
ReadS, -- :: *; = String -> [(a,String)]
readP_to_S, -- :: ReadP a -> ReadS a
readS_to_P, -- :: ReadS a -> ReadP a
readS_to_P -- :: ReadS a -> ReadP a
#if __GLASGOW_HASKELL__ < 603
-- * Properties
-- $properties
#endif
)
where
#if __GLASGOW_HASKELL__ >= 603
import Text.ParserCombinators.ReadP hiding (ReadP)
import qualified Text.ParserCombinators.ReadP as ReadP
type ReadP r a = ReadP.ReadP a
#else
import Control.Monad( MonadPlus(..), liftM2 )
import Data.Char (isSpace)
......@@ -466,3 +479,5 @@ Here follow the properties:
> prop_ReadS r s =
> readP_to_S (readS_to_P r) s =~. r s
-}
#endif
{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Misc
-- Module : Distribution.Extension
-- Copyright : Isaac Jones 2003-2004
--
-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>
-- Stability : alpha
-- Portability :
-- Portability : portable
--
-- Explanation: Misc stuff that doesn't fit elsewhere. License,
-- Dependencies, extensions.
-- Haskell language extensions
{- All rights reserved.
......@@ -40,16 +40,14 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Misc(License(..), Dependency(..), Extension(..), Opt
,extensionsToNHCFlag, extensionsToGHCFlag
,extensionsToHugsFlag
module Distribution.Extension (
Extension(..), Opt,
extensionsToNHCFlag, extensionsToGHCFlag, extensionsToHugsFlag,
#ifdef DEBUG
,hunitTests
hunitTests
#endif
)
where
) where
import Distribution.Version(VersionRange)
import Data.List(nub)
#ifdef DEBUG
......@@ -57,17 +55,9 @@ import HUnit (Test)
#endif
-- ------------------------------------------------------------
-- * Misc
-- * Extension
-- ------------------------------------------------------------
data License = GPL | LGPL | BSD3 | BSD4 | PublicDomain | AllRightsReserved
| {- ... | -} OtherLicense FilePath
deriving (Read, Show, Eq)
-- |Maybe move to Distribution.Version?
data Dependency = Dependency String VersionRange
deriving (Read, Show, Eq)
-- |This represents non-standard compiler extensions which each
-- package might employ.
......
......@@ -49,35 +49,225 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.InstalledPackageInfo (
InstalledPackageInfo(..),
emptyInstalledPackageInfo,
parseInstalledPackageInfo,
showInstalledPackageInfo,
showInstalledPackageInfoField,
) where
import Distribution.Misc(License(..), Dependency, Opt)
import Distribution.Package(PackageIdentifier(..))
import Distribution.ParseUtils (
StanzaField(..), singleStanza, PError(..),
simpleField, listField, licenseField,
parseFilePath, parseLibName, parseModuleName,
showFilePath, parseReadS, parseOptVersion )
import Distribution.License ( License(..) )
import Distribution.Extension ( Opt )
import Distribution.Package ( PackageIdentifier(..), showPackageId,
parsePackageName, parsePackageId )
import Distribution.Version ( Version(..), showVersion )
import Distribution.Compat.ReadP as ReadP
import Control.Monad ( foldM )
import Text.PrettyPrint
-- -----------------------------------------------------------------------------
-- The InstalledPackageInfo type
data InstalledPackageInfo
= InstalledPackageInfo {
pkgIdent :: PackageIdentifier,
license :: License,
copyright :: String,
maintainer :: String,
stability :: String,
auto :: Bool,
importDirs :: [FilePath],
sourceDirs :: [FilePath],
libraryDirs :: [FilePath],
hsLibraries :: [String],
extraLibraries :: [String],
includeDirs :: [FilePath],
cIncludes :: [String],
depends :: [Dependency], -- use dependencies
extraHugsOpts :: [Opt],
extraCcOpts :: [Opt],
extraLdOpts :: [Opt],
frameworkDirs :: [FilePath],
extraFrameworks:: [String]}
-- these parts are exactly the same as PackageDescription
package :: PackageIdentifier,
license :: License,
copyright :: String,
maintainer :: String,
author :: String,
stability :: String,
homepage :: String,
pkgUrl :: String,
description :: String,
category :: String,
-- these parts are required by an installed package only:
exposed :: Bool,
exposedModules :: [String],
hiddenModules :: [String],
importDirs :: [FilePath], -- contain sources in case of Hugs
libraryDirs :: [FilePath],
hsLibraries :: [String],
extraLibraries :: [String],
includeDirs :: [FilePath],
includes :: [String],
depends :: [PackageIdentifier],
extraHugsOpts :: [Opt],
extraCcOpts :: [Opt],
extraLdOpts :: [Opt],
frameworkDirs :: [FilePath],
extraFrameworks :: [String],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath]
}
deriving (Read, Show)
emptyInstalledPackageInfo :: InstalledPackageInfo
emptyInstalledPackageInfo = InstalledPackageInfo (PackageIdentifier "" (error "no version"))
AllRightsReserved "" "" "" False [] [] [] [] [] []
[] [] [] [] [] [] []
emptyInstalledPackageInfo
= InstalledPackageInfo {
package = PackageIdentifier "" noVersion,
license = AllRightsReserved,
copyright = "",
maintainer = "",
author = "",
stability = "",
homepage = "",
pkgUrl = "",
description = "",
category = "",
exposed = False,
exposedModules = [],
hiddenModules = [],
importDirs = [],
libraryDirs = [],
hsLibraries = [],
extraLibraries = [],
includeDirs = [],
includes = [],
depends = [],
extraHugsOpts = [],
extraCcOpts = [],
extraLdOpts = [],
frameworkDirs = [],
extraFrameworks = [],
haddockInterfaces = [],
haddockHTMLs = []
}
noVersion = Version{ versionBranch=[], versionTags=[] }
-- -----------------------------------------------------------------------------
-- Parsing
parseInstalledPackageInfo :: String -> Either PError InstalledPackageInfo
parseInstalledPackageInfo inp = do
lines <- singleStanza inp
-- not interested in stanzas, so just allow blank lines in
-- the package info.
foldM (parseBasicStanza fields) emptyInstalledPackageInfo lines
parseBasicStanza ((StanzaField name _ _ set):fields) pkg (lineNo, f, val)
| name == f = set lineNo val pkg
| otherwise = parseBasicStanza fields pkg (lineNo, f, val)
parseBasicStanza [] pkg (lineNo, f, val) = return pkg
-- -----------------------------------------------------------------------------
-- Pretty-printing
showInstalledPackageInfo :: InstalledPackageInfo -> String
showInstalledPackageInfo pkg = render (ppFields fields)
where
ppFields [] = empty
ppFields ((StanzaField _ get _ _):flds) = get pkg $$ ppFields flds
showInstalledPackageInfoField
:: String
-> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField field
= case [ get | (StanzaField f get _ _) <- fields, f == field ] of
[] -> Nothing
(get:_) -> Just (render . get)
-- -----------------------------------------------------------------------------
-- Description of the fields, for parsing/printing
fields = basicStanzaFields ++ installedStanzaFields
basicStanzaFields :: [StanzaField InstalledPackageInfo]
basicStanzaFields =
[ simpleField "name"
text parsePackageName
(pkgName . package) (\name pkg -> pkg{package=(package pkg){pkgName=name}})
, simpleField "version"
(text . showVersion) parseOptVersion
(pkgVersion . package) (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})
, licenseField "license" False
license (\l pkg -> pkg{license=l})
, licenseField "license-file" True
license (\l pkg -> pkg{license=l})
, simpleField "copyright"
text (munch (const True))
copyright (\val pkg -> pkg{copyright=val})
, simpleField "maintainer"
text (munch (const True))
maintainer (\val pkg -> pkg{maintainer=val})
, simpleField "stability"
text (munch (const True))
stability (\val pkg -> pkg{stability=val})
, simpleField "homepage"
text (munch (const True))
homepage (\val pkg -> pkg{homepage=val})
, simpleField "package-url"
text (munch (const True))
pkgUrl (\val pkg -> pkg{pkgUrl=val})
, simpleField "description"
text (munch (const True))
description (\val pkg -> pkg{description=val})
, simpleField "category"
text (munch (const True))
category (\val pkg -> pkg{category=val})
, simpleField "author"
text (munch (const True))
author (\val pkg -> pkg{author=val})
]
installedStanzaFields :: [StanzaField InstalledPackageInfo]
installedStanzaFields = [
simpleField "exposed"
(text.show) parseReadS
exposed (\val pkg -> pkg{exposed=val})
, listField "exposed-modules"
text parseModuleName
exposedModules (\xs pkg -> pkg{exposedModules=xs})
, listField "hidden-modules"
text parseModuleName
hiddenModules (\xs pkg -> pkg{hiddenModules=xs})
, listField "import-dirs"
showFilePath parseFilePath
importDirs (\xs pkg -> pkg{importDirs=xs})
, listField "library-dirs"
showFilePath parseFilePath
libraryDirs (\xs pkg -> pkg{libraryDirs=xs})
, listField "hs-libraries"
showFilePath parseLibName
hsLibraries (\xs pkg -> pkg{hsLibraries=xs})
, listField "extra-libs"
text parseLibName
extraLibraries (\xs pkg -> pkg{extraLibraries=xs})
, listField "include-dirs"
showFilePath parseFilePath
includeDirs (\xs pkg -> pkg{includeDirs=xs})
, listField "includes"
showFilePath parseFilePath
includes (\xs pkg -> pkg{includes=xs})
, listField "depends"
(text.showPackageId) parsePackageId
depends (\xs pkg -> pkg{depends=xs})
, listField "extra-hugs-opts"
text parseFilePath
extraHugsOpts (\path pkg -> pkg{extraHugsOpts=path})
, listField "extra-cc-opts"
text parseFilePath
extraCcOpts (\path pkg -> pkg{extraCcOpts=path})
, listField "extra-ld-opts"
text parseFilePath
extraLdOpts (\path pkg -> pkg{extraLdOpts=path})
, listField "framework-dirs"
showFilePath parseFilePath
frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs})
, listField "extra-frameworks"
showFilePath parseFilePath
extraFrameworks (\xs pkg -> pkg{extraFrameworks=xs})
, listField "haddock-interfaces"
showFilePath parseFilePath
haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs})
, listField "haddock-html"
showFilePath parseFilePath
haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
]
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.License
-- Copyright : Isaac Jones 2003-2004
--
-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>
-- Stability : alpha
-- Portability : portable
--
-- The License datatype.
{- All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Isaac Jones nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.License (
License(..)
) where
data License = GPL | LGPL | BSD3 | BSD4 | PublicDomain | AllRightsReserved
| {- ... | -} OtherLicense FilePath
deriving (Read, Show, Eq)
......@@ -49,11 +49,12 @@ module Distribution.Make (
-- local
import Distribution.Package --must not specify imports, since we're exporting moule.
import Distribution.PackageDescription
import Distribution.Setup --(parseArgs, Action(..), optionHelpString)
import Distribution.Simple.Utils (maybeExit)
import Distribution.Misc (License(..))
import Distribution.License (License(..))
import Distribution.Version (Version(..))
import System.Environment(getArgs)
......
......@@ -46,9 +46,11 @@ module Main where
import qualified Distribution.Version as D.V (hunitTests)
-- import qualified Distribution.InstalledPackageInfo(hunitTests)
import qualified Distribution.Misc as D.M (hunitTests)
import qualified Distribution.License as D.L
import qualified Distribution.Extension as D.E (hunitTests)
import qualified Distribution.Make ()
import qualified Distribution.Package as D.P (hunitTests)
import qualified Distribution.Package as D.P ()
import qualified Distribution.PackageDescription as D.PD (hunitTests)
import qualified Distribution.Setup as D.Setup (hunitTests)
import qualified Distribution.Simple as D.S (simpleHunitTests)
......@@ -56,7 +58,7 @@ import qualified Distribution.Simple.Install as D.S.I (hunitTests)
import qualified Distribution.Simple.Build as D.S.B (hunitTests)
import qualified Distribution.Simple.SrcDist as D.S.S (hunitTests)
import qualified Distribution.Simple.Utils as D.S.U (hunitTests)
import Distribution.Simple.Utils(pathJoin)
import Distribution.Compat.FilePath(joinFileName)
import qualified Distribution.Simple.Configure as D.S.C (hunitTests, localBuildInfoFile)
import qualified Distribution.Simple.Register as D.S.R (hunitTests, installedPkgConfigFile)
......@@ -109,8 +111,9 @@ assertCmd command comment
tests :: FilePath -> [Test]
tests currDir
= [TestLabel "testing the wash2hs package" $ TestCase $
do setCurrentDirectory $ pathJoin [currDir, "test", "wash2hs"]
= let testdir = currDir `joinFileName` "test" in
[TestLabel "testing the wash2hs package" $ TestCase $
do setCurrentDirectory $ (testdir `joinFileName` "wash2hs")
system "make clean"
system "make"
assertCmd "./setup configure --prefix=\",tmp\"" "wash2hs configure"
......@@ -123,7 +126,7 @@ tests currDir
perms <- getPermissions ",tmp/bin/wash2hs"
assertBool "wash2hs isn't +x" (executable perms),
TestLabel "testing the HUnit package" $ TestCase $
do setCurrentDirectory $ pathJoin [currDir, "test", "HUnit-1.0"]
do setCurrentDirectory $ (testdir `joinFileName` "HUnit-1.0")
pkgConf <- GHC.localPackageConfig
GHC.maybeCreateLocalPackageConfig
system $ "ghc-pkg --config-file=" ++ pkgConf ++ " -r HUnit"
......@@ -157,7 +160,7 @@ tests currDir
do pkgConf <- GHC.localPackageConfig
GHC.maybeCreateLocalPackageConfig
system $ "ghc-pkg -r test --config-file=" ++ pkgConf
setCurrentDirectory $ pathJoin [currDir, "test", "A"]
setCurrentDirectory $ (testdir `joinFileName` "A")
system "make clean"
system "make"
assertCmd "./setup configure --ghc --prefix=,tmp"
......@@ -183,14 +186,14 @@ tests currDir
do let targetDir = ",tmp2"
instRetCode <- system $ "./setup install --install-prefix=" ++ targetDir