diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.4.0.2 +Version: 1.6.0.1 Copyright: 2003-2006, Isaac Jones 2005-2008, Duncan Coutts License: BSD3 @@ -8,15 +8,15 @@ Duncan Coutts Maintainer: cabal-devel@haskell.org Homepage: http://www.haskell.org/cabal/ +--bug-reports: http://hackage.haskell.org/trac/hackage/ Synopsis: A framework for packaging Haskell software Description: The Haskell Common Architecture for Building Applications and Libraries: a framework defining a common interface for authors to more easily build their Haskell applications in a portable way. . - The Haskell Cabal is meant to be a part of a larger infrastructure - for distributing, organizing, and cataloging Haskell libraries - and tools. + The Haskell Cabal is part of a larger infrastructure for distributing, + organizing, and cataloging Haskell libraries and tools. Category: Distribution Build-Type: Custom -- Even though we do use the default Setup.lhs it's vital to bootstrapping @@ -27,41 +27,54 @@ Distribution/Simple/GHC/mkGHCMakefile.sh Distribution/Simple/GHC/Makefile.in -Flag small_base - Description: Choose the new smaller, split-up base package. +--source-repository head +-- type: darcs +-- location: http://darcs.haskell.org/cabal/ +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Flag base3 + Description: Choose the new smaller, split-up base package. + Library - if flag(small_base) - Build-Depends: base >= 3 && < 4, - directory >= 1 && < 1.1, + if flag(base4) + Build-Depends: base >= 4 && < 5 + if flag(base3) + Build-Depends: base >= 3 && < 4 + if !flag(base3) && !flag(base4) + Build-Depends: base < 3 + + if flag(base3) || flag(base4) + Build-Depends: directory >= 1 && < 1.1, process >= 1 && < 1.1, old-time >= 1 && < 1.1, - containers >= 0.1 && < 0.2, - array >= 0.1 && < 0.2, + containers >= 0.1 && < 0.3, + array >= 0.1 && < 0.3, pretty >= 1 && < 1.1 - else - Build-Depends: base < 3 Build-Depends: filepath >= 1 && < 1.2 GHC-Options: -Wall - CPP-Options: "-DCABAL_VERSION=1,4,0,2" + CPP-Options: "-DCABAL_VERSION=1,6,0,1" nhc98-Options: -K4M Exposed-Modules: Distribution.Compiler, - Distribution.Extension, - Distribution.Setup, Distribution.InstalledPackageInfo, Distribution.License, Distribution.Make, + Distribution.ModuleName, Distribution.Package, Distribution.PackageDescription, Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.Parse, Distribution.PackageDescription.Check, Distribution.ParseUtils, Distribution.ReadE, Distribution.Simple, Distribution.Simple.Build, + Distribution.Simple.Build.Macros, + Distribution.Simple.Build.PathsModule, Distribution.Simple.BuildPaths, Distribution.Simple.Command, Distribution.Simple.Compiler, @@ -80,7 +93,6 @@ Distribution.Simple.Program, Distribution.Simple.Register, Distribution.Simple.Setup, - Distribution.Simple.SetupWrapper, Distribution.Simple.SrcDist, Distribution.Simple.UserHooks, Distribution.Simple.Utils, @@ -93,7 +105,11 @@ Other-Modules: Distribution.GetOpt, - Distribution.Compat.TempFile - Distribution.Simple.GHC.Makefile + Distribution.Compat.Exception, + Distribution.Compat.Permissions, + Distribution.Compat.TempFile, + Distribution.Simple.GHC.Makefile, + Distribution.Simple.GHC.IPI641, + Distribution.Simple.GHC.IPI642 Extensions: CPP diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Exception.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} + +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 609) +#define NEW_EXCEPTION +#endif + +module Distribution.Compat.Exception + (onException, catchIO, catchExit, throwIOIO) + where + +import System.Exit +import qualified Control.Exception as Exception + +onException :: IO a -> IO b -> IO a +#ifdef NEW_EXCEPTION +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#ifdef NEW_EXCEPTION +throwIOIO = Exception.throwIO +#else +throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchIO = Exception.catch +#else +catchIO io handler = io `Exception.catch` handler' + where handler' (Exception.IOException ioe) = handler ioe + handler' e = Exception.throw e +#endif + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchExit = Exception.catch +#else +catchExit io handler = io `Exception.catch` handler' + where handler' (Exception.ExitException ee) = handler ee + handler' e = Exception.throw e +#endif + diff --git a/Distribution/Compat/Permissions.hs b/Distribution/Compat/Permissions.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Permissions.hs @@ -0,0 +1,34 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} + +module Distribution.Compat.Permissions (copyPermissions) where + +#ifndef __NHC__ +import Foreign +import Foreign.C +import System.Posix.Internals + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions source dest = do + allocaBytes sizeof_stat $ \ p_stat -> do + withCString source $ \p_source -> do + withCString dest $ \p_dest -> do + throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat + mode <- st_mode p_stat + throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode + +#else +import Directory (Permissions(..),getPermissions,setPermissions) + +-- The nhc98 version of this function is broken. (But it is the way ghc +-- and Hugs implemented it too, until 2008-09-13.) Unfortunately, nhc98 +-- does not have System.Posix.Internals, so cannot (yet) do it correctly. +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions source dest = do + perms <- getPermissions source + setPermissions dest perms +#endif diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs --- a/Distribution/Compat/ReadP.hs +++ b/Distribution/Compat/ReadP.hs @@ -1,16 +1,14 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.ReadP -- Copyright : (c) The University of Glasgow 2002 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org --- Stability : provisional -- Portability : portable -- -- This is a library of parser combinators, originally written by Koen Claessen. --- It parses all alternatives in parallel, so it never keeps hold of +-- It parses all alternatives in parallel, so it never keeps hold of -- the beginning of the input string, a common source of space leaks with -- other parsers. The '(+++)' choice combinator is genuinely commutative; -- it makes no difference which branch is \"shorter\". @@ -24,17 +22,17 @@ ----------------------------------------------------------------------------- module Distribution.Compat.ReadP - ( + ( -- * The 'ReadP' type ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus - + -- * Primitive operations get, -- :: ReadP Char look, -- :: ReadP String (+++), -- :: ReadP a -> ReadP a -> ReadP a (<++), -- :: ReadP a -> ReadP a -> ReadP a gather, -- :: ReadP a -> ReadP (String, a) - + -- * Other operations pfail, -- :: ReadP a satisfy, -- :: (Char -> Bool) -> ReadP Char @@ -61,28 +59,17 @@ chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] - + -- * Running a parser ReadS, -- :: *; = String -> [(a,String)] readP_to_S, -- :: ReadP a -> ReadS a readS_to_P -- :: ReadS a -> ReadP a - -#if __GLASGOW_HASKELL__ < 603 && !__HUGS__ + -- * Properties -- $properties -#endif ) where -#if __GLASGOW_HASKELL__ >= 603 || __HUGS__ - -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) @@ -117,7 +104,7 @@ -- most common case: two gets are combined Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) - + -- results are delivered as soon as possible Result x p `mplus` q = Result x (p `mplus` q) p `mplus` Result x q = Result x (p `mplus` q) @@ -218,9 +205,9 @@ -- ^ Transforms a parser into one that does the same, but -- in addition returns the exact characters read. -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument --- is built using any occurrences of readS_to_P. +-- is built using any occurrences of readS_to_P. gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) where gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) gath _ Fail = Fail @@ -449,7 +436,7 @@ > xs +<+ _ = xs > > prop_Gather s = -> forAll readPWithoutReadS $ \p -> +> forAll readPWithoutReadS $ \p -> > readP_to_S (gather p) s =~ > [ ((pre,x::Int),s') > | (x,s') <- readP_to_S p s @@ -480,4 +467,3 @@ > readP_to_S (readS_to_P r) s =~. r s -} -#endif diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs --- a/Distribution/Compat/TempFile.hs +++ b/Distribution/Compat/TempFile.hs @@ -5,7 +5,8 @@ {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp #-} -- #hide -module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) where +module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile, + openNewBinaryFile) where #if __NHC__ || __HUGS__ import System.IO (openFile, openBinaryFile, @@ -19,7 +20,12 @@ import System.Posix.Internals (c_getpid) #endif #else -import System.IO (openTempFile, openBinaryTempFile) +import System.IO +import Data.Bits +import System.Posix.Internals +import Foreign.C +import GHC.Handle +import Distribution.Compat.Exception #endif -- ------------------------------------------------------------ @@ -61,6 +67,82 @@ else do hnd <- openBinaryFile path ReadWriteMode return (path, hnd) +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFile + getProcessID :: IO Int getProcessID = fmap fromIntegral c_getpid +#else +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + + findTempName x = do + fd <- withCString filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- XXX We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#else + fdToHandle (fromIntegral fd) +#endif + `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- XXX bits copied from System.FilePath, since that's not available here + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- XXX Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- XXX Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR #endif diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -2,12 +2,24 @@ -- | -- Module : Distribution.Compiler -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Haskell compiler flavors +-- This has an enumeration of the various compilers that Cabal knows about. It +-- also specifies the default compiler. Sadly you'll often see code that does +-- case analysis on this compiler flavour enumeration like: +-- +-- > case compilerFlavor comp of +-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf +-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf +-- +-- Obviously it would be better to use the proper 'Compiler' abstraction +-- because that would keep all the compiler-specific code together. +-- Unfortunately we cannot make this change yet without breaking the +-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the +-- moment we just have to live with this deficiency. If you're interested, see +-- ticket #50. {- All rights reserved. diff --git a/Distribution/Extension.hs b/Distribution/Extension.hs deleted file mode 100644 --- a/Distribution/Extension.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Extension --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Haskell language extensions - -{- 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.Extension -{-# DEPRECATED "Use modules Language.Haskell.Extension and Distribution.Compiler instead" #-} - (Extension(..) - ) where - -import Language.Haskell.Extension (Extension(..)) diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs --- a/Distribution/GetOpt.hs +++ b/Distribution/GetOpt.hs @@ -3,13 +3,12 @@ -- Module : Distribution.GetOpt -- Copyright : (c) Sven Panne 2002-2005 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org --- Stability : experimental -- Portability : portable -- -- This library provides facilities for parsing the command-line options --- in a standalone program. It is essentially a Haskell port of the GNU +-- in a standalone program. It is essentially a Haskell port of the GNU -- @getopt@ library. -- ----------------------------------------------------------------------------- @@ -33,7 +32,7 @@ compliant... :-( And a final Haskell advertisement: The GNU C implementation uses well -over 1100 lines, we need only 195 here, including a 46 line example! +over 1100 lines, we need only 195 here, including a 46 line example! :-) -} @@ -93,7 +92,7 @@ | OptErr String -- something went wrong... -- | Return a string describing the usage of a command, derived from --- the header (first argument) and the options described by the +-- the header (first argument) and the options described by the -- second argument. usageInfo :: String -- header -> [OptDescr a] -- option descriptors @@ -104,15 +103,15 @@ ,d) | Option sos los ad d <- optDescr ] ssWidth = (maximum . map length) ss - lsWidth = (maximum . map length) ls - dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) + lsWidth = (maximum . map length) ls + dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) table = [ " " ++ padTo ssWidth so' ++ " " ++ padTo lsWidth lo' ++ " " ++ d' | (so,lo,d) <- zip3 ss ls ds , (so',lo',d') <- fmtOpt dsWidth so lo d ] padTo n x = take n (x ++ repeat ' ') - sepBy s = concat . intersperse s + sepBy s = concat . intersperse s fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] fmtOpt descrWidth so lo descr = @@ -153,7 +152,7 @@ * The option descriptions (see 'OptDescr') -* The actual command line arguments (presumably got from +* The actual command line arguments (presumably got from 'System.Environment.getArgs'). 'getOpt' returns a triple consisting of the option arguments, a list @@ -234,7 +233,7 @@ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt optStr,('-':xs):rest) + short [] xs rest = (UnreqOpt (optStr++xs),rest) -- miscellaneous error formatting @@ -288,11 +287,11 @@ -- putStr (test Permute ["--ver","foo"]) -- ==> option `--ver' is ambiguous; could be one of: -- -v --verbose verbosely list files --- -V, -? --version, --release show version info +-- -V, -? --version, --release show version info -- Usage: foobar [OPTION...] files... --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- -o[FILE] --output[=FILE] use FILE for dump +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump -- -n USER --name=USER only dump USER's files ----------------------------------------------------------------------------------------- -} @@ -304,15 +303,15 @@ compiler: > module Opts where -> +> > import Distribution.GetOpt > import Data.Maybe ( fromMaybe ) -> -> data Flag -> = Verbose | Version +> +> data Flag +> = Verbose | Version > | Input String | Output String | LibDir String > deriving Show -> +> > options :: [OptDescr Flag] > options = > [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" @@ -321,13 +320,13 @@ > , Option ['c'] [] (OptArg inp "FILE") "input FILE" > , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" > ] -> +> > inp,outp :: Maybe String -> Flag > outp = Output . fromMaybe "stdout" > inp = Input . fromMaybe "stdin" -> +> > compilerOpts :: [String] -> IO ([Flag], [String]) -> compilerOpts argv = +> compilerOpts argv = > case getOpt Permute options argv of > (o,n,[] ) -> return (o,n) > (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -2,16 +2,25 @@ -- | -- Module : Distribution.InstalledPackageInfo -- Copyright : (c) The University of Glasgow 2004 --- +-- -- Maintainer : libraries@haskell.org --- Stability : alpha -- Portability : portable -- -- This is the information about an /installed/ package that --- is communicated to the @hc-pkg@ program in order to register --- a package. @ghc-pkg@ now consumes this package format (as of verison +-- is communicated to the @ghc-pkg@ program in order to register +-- a package. @ghc-pkg@ now consumes this package format (as of version -- 6.4). This is specific to GHC at the moment. - +-- +-- The @.cabal@ file format is for describing a package that is not yet +-- installed. It has a lot of flexibility, like conditionals and dependency +-- ranges. As such, that format is not at all suitable for describing a package +-- that has already been built and installed. By the time we get to that stage, +-- we have resolved all conditionals and resolved dependency version +-- constraints to exact versions of dependent packages. So, this module defines +-- the 'InstalledPackageInfo' data structure that contains all the info we keep +-- about an installed package. There is a parser and pretty printer. The +-- textual format is rather simpler than the @.cabal@ format: there are no +-- sections, for example. {- All rights reserved. @@ -46,69 +55,70 @@ -- This module is meant to be local-only to Distribution... module Distribution.InstalledPackageInfo ( - InstalledPackageInfo_(..), InstalledPackageInfo, - ParseResult(..), PError(..), PWarning, - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showInstalledPackageInfoField, + InstalledPackageInfo_(..), InstalledPackageInfo, + ParseResult(..), PError(..), PWarning, + emptyInstalledPackageInfo, + parseInstalledPackageInfo, + showInstalledPackageInfo, + showInstalledPackageInfoField, ) where -import Distribution.ParseUtils ( - FieldDescr(..), readFields, ParseResult(..), PError(..), PWarning, - Field(F), simpleField, listField, parseLicenseQ, ppField, ppFields, - parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ, - showFilePath, showToken, boolField, parseOptVersion, parseQuoted, - showFreeText) -import Distribution.License ( License(..) ) +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), PError(..), PWarning + , simpleField, listField, parseLicenseQ + , showFields, showSingleNamedField, parseFields + , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ + , showFilePath, showToken, boolField, parseOptVersion, parseQuoted + , parseFreeText, showFreeText ) +import Distribution.License ( License(..) ) import Distribution.Package - ( PackageIdentifier(..), packageName, packageVersion ) + ( PackageName(..), PackageIdentifier(..) + , packageName, packageVersion ) import qualified Distribution.Package as Package ( Package(..), PackageFixedDeps(..) ) +import Distribution.ModuleName + ( ModuleName ) import Distribution.Version ( Version(..) ) import Distribution.Text ( Text(disp, parse) ) import qualified Distribution.Compat.ReadP as ReadP -import Control.Monad ( foldM ) -import Text.PrettyPrint - -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type data InstalledPackageInfo_ m = InstalledPackageInfo { - -- these parts are exactly the same as PackageDescription - package :: PackageIdentifier, + -- these parts are exactly the same as PackageDescription + package :: PackageIdentifier, license :: License, copyright :: String, maintainer :: String, - author :: String, + author :: String, stability :: String, - homepage :: String, - pkgUrl :: String, - description :: String, - category :: String, - -- these parts are required by an installed package only: + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + -- these parts are required by an installed package only: exposed :: Bool, - exposedModules :: [m], - hiddenModules :: [m], + exposedModules :: [m], + hiddenModules :: [m], importDirs :: [FilePath], -- contain sources in case of Hugs libraryDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], - extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi + extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi includeDirs :: [FilePath], includes :: [String], depends :: [PackageIdentifier], - hugsOptions :: [String], - ccOptions :: [String], - ldOptions :: [String], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath] + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] } deriving (Read, Show) @@ -117,39 +127,39 @@ instance Package.PackageFixedDeps (InstalledPackageInfo_ str) where depends = depends -type InstalledPackageInfo = InstalledPackageInfo_ String +type InstalledPackageInfo = InstalledPackageInfo_ ModuleName emptyInstalledPackageInfo :: InstalledPackageInfo_ m emptyInstalledPackageInfo = InstalledPackageInfo { - package = PackageIdentifier "" noVersion, + package = PackageIdentifier (PackageName "") noVersion, license = AllRightsReserved, copyright = "", maintainer = "", - author = "", + author = "", stability = "", - homepage = "", - pkgUrl = "", - description = "", - category = "", + homepage = "", + pkgUrl = "", + description = "", + category = "", exposed = False, - exposedModules = [], - hiddenModules = [], + exposedModules = [], + hiddenModules = [], importDirs = [], libraryDirs = [], hsLibraries = [], extraLibraries = [], extraGHCiLibraries= [], includeDirs = [], - includes = [], + includes = [], depends = [], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [] + haddockInterfaces = [], + haddockHTMLs = [] } noVersion :: Version @@ -159,36 +169,16 @@ -- Parsing parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo -parseInstalledPackageInfo inp = do - stLines <- readFields inp - -- not interested in stanzas, so just allow blank lines in - -- the package info. - foldM (parseBasicStanza all_fields) emptyInstalledPackageInfo stLines - -parseBasicStanza :: [FieldDescr a] - -> a - -> Field - -> ParseResult a -parseBasicStanza ((FieldDescr name _ set):fields) pkg (F lineNo f val) - | name == f = set lineNo val pkg - | otherwise = parseBasicStanza fields pkg (F lineNo f val) -parseBasicStanza [] pkg _ = return pkg -parseBasicStanza _ _ _ = - error "parseBasicStanza must be called with a simple field." +parseInstalledPackageInfo = parseFields all_fields emptyInstalledPackageInfo -- ----------------------------------------------------------------------------- -- Pretty-printing showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo pkg = render (ppFields pkg all_fields) +showInstalledPackageInfo = showFields all_fields -showInstalledPackageInfoField - :: String - -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField field - = case [ (f,get') | (FieldDescr f get' _) <- all_fields, f == field ] of - [] -> Nothing - ((f,get'):_) -> Just (render . ppField f . get') +showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showInstalledPackageInfoField = showSingleNamedField all_fields -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing @@ -199,7 +189,7 @@ basicFieldDescrs :: [FieldDescr InstalledPackageInfo] basicFieldDescrs = [ simpleField "name" - text parsePackageNameQ + disp parsePackageNameQ packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) , simpleField "version" disp parseOptVersion @@ -233,64 +223,61 @@ author (\val pkg -> pkg{author=val}) ] -parseFreeText :: ReadP.ReadP s String -parseFreeText = ReadP.munch (const True) - installedFieldDescrs :: [FieldDescr InstalledPackageInfo] installedFieldDescrs = [ boolField "exposed" - exposed (\val pkg -> pkg{exposed=val}) + exposed (\val pkg -> pkg{exposed=val}) , listField "exposed-modules" - text parseModuleNameQ - exposedModules (\xs pkg -> pkg{exposedModules=xs}) + disp parseModuleNameQ + exposedModules (\xs pkg -> pkg{exposedModules=xs}) , listField "hidden-modules" - text parseModuleNameQ - hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) + disp parseModuleNameQ + hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) , listField "import-dirs" - showFilePath parseFilePathQ - importDirs (\xs pkg -> pkg{importDirs=xs}) + showFilePath parseFilePathQ + importDirs (\xs pkg -> pkg{importDirs=xs}) , listField "library-dirs" - showFilePath parseFilePathQ - libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) + showFilePath parseFilePathQ + libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) , listField "hs-libraries" - showFilePath parseTokenQ - hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) + showFilePath parseTokenQ + hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) , listField "extra-libraries" - showToken parseTokenQ - extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) + showToken parseTokenQ + extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) , listField "extra-ghci-libraries" - showToken parseTokenQ - extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) + showToken parseTokenQ + extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) , listField "include-dirs" - showFilePath parseFilePathQ - includeDirs (\xs pkg -> pkg{includeDirs=xs}) + showFilePath parseFilePathQ + includeDirs (\xs pkg -> pkg{includeDirs=xs}) , listField "includes" - showFilePath parseFilePathQ - includes (\xs pkg -> pkg{includes=xs}) + showFilePath parseFilePathQ + includes (\xs pkg -> pkg{includes=xs}) , listField "depends" - disp parsePackageId' - depends (\xs pkg -> pkg{depends=xs}) + disp parsePackageId' + depends (\xs pkg -> pkg{depends=xs}) , listField "hugs-options" - showToken parseTokenQ - hugsOptions (\path pkg -> pkg{hugsOptions=path}) + showToken parseTokenQ + hugsOptions (\path pkg -> pkg{hugsOptions=path}) , listField "cc-options" - showToken parseTokenQ - ccOptions (\path pkg -> pkg{ccOptions=path}) + showToken parseTokenQ + ccOptions (\path pkg -> pkg{ccOptions=path}) , listField "ld-options" - showToken parseTokenQ - ldOptions (\path pkg -> pkg{ldOptions=path}) + showToken parseTokenQ + ldOptions (\path pkg -> pkg{ldOptions=path}) , listField "framework-dirs" - showFilePath parseFilePathQ - frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) + showFilePath parseFilePathQ + frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) , listField "frameworks" - showToken parseTokenQ - frameworks (\xs pkg -> pkg{frameworks=xs}) + showToken parseTokenQ + frameworks (\xs pkg -> pkg{frameworks=xs}) , listField "haddock-interfaces" - showFilePath parseFilePathQ - haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) + showFilePath parseFilePathQ + haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) , listField "haddock-html" - showFilePath parseFilePathQ - haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) + showFilePath parseFilePathQ + haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) ] parsePackageId' :: ReadP.ReadP [PackageIdentifier] PackageIdentifier diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -2,18 +2,19 @@ -- | -- Module : Distribution.License -- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- The License datatype. For more information about these and other -- open-source licenses, you may visit . -- --- I am not a lawyer, but as a general guideline, most Haskell --- software seems to be released under a BSD3 license, which is very --- open and free. If you don't want to restrict the use of your --- software or its source code, use BSD3 or PublicDomain. +-- The @.cabal@ file allows you to specify a license file. Of course you can +-- use any license you like but people often pick common open source licenses +-- and it's useful if we can automatically recognise that (eg so we can display +-- it on the hackage web pages). So you can also specify the license itself in +-- the @.cabal@ file from a short enumeration defined in this module. It +-- includes 'GPL', 'LGPL' and 'BSD3' licenses. {- All rights reserved. @@ -46,7 +47,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.License ( - License(..) + License(..) ) where import Distribution.Version (Version) @@ -115,7 +116,7 @@ name <- Parse.munch1 Char.isAlphaNum version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) -- We parse an optional version but do not yet allow it on any known - -- license. However parsing the version will allow forwards compatability + -- license. However parsing the version will allow forwards compatibility -- for when we do introduce optional (L)GPL license versions. return $ case (name, version :: Maybe Version) of ("GPL", Nothing) -> GPL diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -2,48 +2,56 @@ -- | -- Module : Distribution.Make -- Copyright : Martin Sjögren 2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- that it works. +-- -- Uses the parsed command-line from Distribution.Setup in order to build -- Haskell tools using a backend build system based on make. Obviously we -- assume that there is a configure script, and that after the ConfigCmd has -- been run, there is a Makefile. Further assumptions: --- +-- -- [ConfigCmd] We assume the configure script accepts --- @--with-hc@, --- @--with-hc-pkg@, --- @--prefix@, --- @--bindir@, --- @--libdir@, --- @--libexecdir@, --- @--datadir@. --- +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- -- [BuildCmd] We assume that the default Makefile target will build everything. --- +-- -- [InstallCmd] We assume there is an @install@ target. Note that we assume that -- this does *not* register the package! --- --- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. --- The @copy@ target should probably just invoke @make install@ --- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) --- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make --- install@ directly here is that we don\'t know the value of @$(prefix)@. --- +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- -- [SDistCmd] We assume there is a @dist@ target. --- +-- -- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. --- +-- -- [UnregisterCmd] We assume there is an @unregister@ target. --- +-- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target. --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ {- All rights reserved. @@ -76,9 +84,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Make ( - module Distribution.Package, - License(..), Version(..), - defaultMain, defaultMainArgs, defaultMainNoRead + module Distribution.Package, + License(..), Version(..), + defaultMain, defaultMainArgs, defaultMainNoRead ) where -- local @@ -121,7 +129,7 @@ _ | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts + CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo action -> action @@ -160,11 +168,11 @@ copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do noExtraFlags args - let destArgs = case fromFlag $ copyDest' flags of + let destArgs = case fromFlag $ copyDest flags of NoCopyDest -> ["install"] CopyTo path -> ["copy", "destdir=" ++ path] CopyPrefix path -> ["install", "prefix=" ++ path] - -- CopyPrefix is backwards compat, DEPRECATED + -- CopyPrefix is backwards compat, DEPRECATED rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs installAction :: InstallFlags -> [String] -> IO () @@ -174,7 +182,7 @@ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] haddockAction :: HaddockFlags -> [String] -> IO () -haddockAction flags args = do +haddockAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] `catch` \_ -> diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs new file mode 100644 --- /dev/null +++ b/Distribution/ModuleName.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ModuleName +-- Copyright : Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Data type for Haskell module names. + +{- 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.ModuleName ( + ModuleName, + simple, + components, + toFilePath, + main, + ) where + +import Distribution.Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char + ( isAlphaNum, isUpper ) +import System.FilePath + ( pathSeparator ) +import Data.List + ( intersperse ) +import Control.Exception + ( assert ) + +newtype ModuleName = ModuleName [String] + deriving (Eq, Ord, Read, Show) + +instance Text ModuleName where + disp (ModuleName ms) = + Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) + + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (ModuleName ms) + + where + component = do + c <- Parse.satisfy Char.isUpper + cs <- Parse.munch (\x -> Char.isAlphaNum x || x == '_' || x == '\'') + return (c:cs) + +simple :: String -> ModuleName +simple name = assert (all (/='.') name) + (ModuleName [name]) + +main :: ModuleName +main = ModuleName ["Main"] + +components :: ModuleName -> [String] +components (ModuleName ms) = ms + +toFilePath :: ModuleName -> FilePath +toFilePath = concat . intersperse [pathSeparator] . components diff --git a/Distribution/Package.hs b/Distribution/Package.hs --- a/Distribution/Package.hs +++ b/Distribution/Package.hs @@ -2,12 +2,14 @@ -- | -- Module : Distribution.Package -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Packages are fundamentally just a name and a version. +-- Defines a package identifier along with a parser and pretty printer for it. +-- 'PackageIdentifier's consist of a name and an exact version. It also defines +-- a 'Dependency' data type. A dependency is a package name and a version +-- range, like @\"foo >= 1.2 && < 2\"@. {- All rights reserved. @@ -40,27 +42,25 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Package ( - -- * Package ids - PackageIdentifier(..), - parsePackageName, + -- * Package ids + PackageName(..), + PackageIdentifier(..), + PackageId, -- * Package dependencies Dependency(..), thisPackageVersion, notThisPackageVersion, - -- * Package classes - Package(..), packageName, packageVersion, - PackageFixedDeps(..), - - -- * Deprecated compat stuff - showPackageId, + -- * Package classes + Package(..), packageName, packageVersion, + PackageFixedDeps(..), ) where import Distribution.Version ( Version(..), VersionRange(AnyVersion,ThisVersion), notThisVersion ) -import Distribution.Text (Text(..), display) +import Distribution.Text (Text(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((<++)) import qualified Text.PrettyPrint as Disp @@ -68,45 +68,54 @@ import qualified Data.Char as Char ( isDigit, isAlphaNum ) import Data.List ( intersperse ) +newtype PackageName = PackageName String + deriving (Read, Show, Eq, Ord) + +instance Text PackageName where + disp (PackageName n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PackageName (concat (intersperse "-" ns))) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + -- | The name and version of a package. data PackageIdentifier = PackageIdentifier { - pkgName :: String, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 } deriving (Read, Show, Eq, Ord) instance Text PackageIdentifier where disp (PackageIdentifier n v) = case v of - Version [] _ -> Disp.text n -- if no version, don't show version. - _ -> Disp.text n <> Disp.char '-' <> disp v + Version [] _ -> disp n -- if no version, don't show version. + _ -> disp n <> Disp.char '-' <> disp v parse = do - n <- parsePackageName + n <- parse v <- (Parse.char '-' >> parse) <++ return (Version [] []) return (PackageIdentifier n v) -parsePackageName :: Parse.ReadP r String -parsePackageName = do ns <- Parse.sepBy1 component (Parse.char '-') - return (concat (intersperse "-" ns)) - where component = do - cs <- Parse.munch1 Char.isAlphaNum - if all Char.isDigit cs then Parse.pfail else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - -- ------------------------------------------------------------ -- * Package dependencies -- ------------------------------------------------------------ -data Dependency = Dependency String VersionRange +data Dependency = Dependency PackageName VersionRange deriving (Read, Show, Eq) instance Text Dependency where disp (Dependency name ver) = - Disp.text name <+> disp ver + disp name <+> disp ver - parse = do name <- parsePackageName + parse = do name <- parse Parse.skipSpaces ver <- parse <++ return AnyVersion Parse.skipSpaces @@ -129,7 +138,7 @@ class Package pkg where packageId :: pkg -> PackageIdentifier -packageName :: Package pkg => pkg -> String +packageName :: Package pkg => pkg -> PackageName packageName = pkgName . packageId packageVersion :: Package pkg => pkg -> Version @@ -147,10 +156,3 @@ -- class Package pkg => PackageFixedDeps pkg where depends :: pkg -> [PackageIdentifier] - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -{-# DEPRECATED showPackageId "use the Text class instead" #-} -showPackageId :: PackageIdentifier -> String -showPackageId = display diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -2,1329 +2,684 @@ -- | -- Module : Distribution.PackageDescription -- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Package description and parsing. - -{- 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.PackageDescription ( - -- * Package descriptions - PackageDescription(..), - GenericPackageDescription(..), - emptyPackageDescription, - readPackageDescription, - writePackageDescription, - parsePackageDescription, - showPackageDescription, - BuildType(..), - knownBuildTypes, - - -- ** Libraries - Library(..), - emptyLibrary, - withLib, - hasLibs, - libModules, - - -- ** Executables - Executable(..), - emptyExecutable, - withExe, - hasExes, - exeModules, - - -- ** Parsing - FieldDescr(..), - LineNo, - - -- * Build information - BuildInfo(..), - emptyBuildInfo, - allBuildInfo, - hcOptions, - - -- ** Supplementary build information - HookedBuildInfo, - emptyHookedBuildInfo, - updatePackageDescription, - - -- * package configuration - Flag(..), FlagName(..), FlagAssignment, - CondTree(..), ConfVar(..), Condition(..), - freeVars, - - -- ** Supplementary build information - readHookedBuildInfo, - parseHookedBuildInfo, - writeHookedBuildInfo, - showHookedBuildInfo, - - -- * Deprecated compat stuff - ParseResult(..), - setupMessage, - cabalVersion, - ) where - -import Data.Maybe (listToMaybe) -import Data.List (nub, unfoldr, partition, (\\)) -import Data.Monoid (Monoid(mempty, mappend)) -import Text.PrettyPrint.HughesPJ as Disp -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((+++)) -import qualified Data.Char as Char (isAlphaNum, isSpace) -import Control.Monad (liftM, foldM, when, unless) -import System.Directory (doesFileExist) - -import Distribution.Package - ( PackageIdentifier(..), Dependency, Package(..) - , parsePackageName, packageName, packageVersion ) -import Distribution.Version - ( Version(Version), VersionRange(AnyVersion) - , isAnyVersion, withinRange ) -import Distribution.License (License(AllRightsReserved)) -import Distribution.Compiler (CompilerFlavor(..)) -import Distribution.System (OS, Arch) -import Distribution.ParseUtils -import Distribution.Text - ( Text(..), display, simpleParse ) -import Distribution.Simple.Utils - ( notice, die, dieWithLocation, warn, intercalate - , lowercase, cabalVersion, readUTF8File, writeUTF8File ) -import Language.Haskell.Extension (Extension) -import Distribution.Verbosity (Verbosity) - - --- ----------------------------------------------------------------------------- --- The PackageDescription type - --- | This data type is the internal representation of the file @pkg.cabal@. --- It contains two kinds of information about the package: information --- which is needed for all packages, such as the package name and version, and --- information which is needed for the simple build system only, such as --- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - package :: PackageIdentifier, - license :: License, - licenseFile :: FilePath, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: String, - pkgUrl :: String, - synopsis :: String, -- ^A one-line summary of this package - description :: String, -- ^A more verbose description of this package - category :: String, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - buildDepends :: [Dependency], - descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here. - buildType :: Maybe BuildType, - -- components - library :: Maybe Library, - executables :: [Executable], - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath] - } - deriving (Show, Read, Eq) - -instance Package PackageDescription where - packageId = package - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription {package = PackageIdentifier "" (Version [] []), - license = AllRightsReserved, - licenseFile = "", - descCabalVersion = AnyVersion, - buildType = Nothing, - copyright = "", - maintainer = "", - author = "", - stability = "", - testedWith = [], - buildDepends = [], - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - customFieldsPD = [], - library = Nothing, - executables = [], - dataFiles = [], - dataDir = "", - extraSrcFiles = [], - extraTmpFiles = [] - } - --- | The type of build system used by this package. -data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - | UnknownBuildType String - -- ^ a package that uses an unknown build type cannot actually - -- be built. Doing it this way rather than just giving a - -- parse error means we get better error messages and allows - -- you to inspect the rest of the package description. - deriving (Show, Read, Eq) - -knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] - -instance Text BuildType where - disp (UnknownBuildType other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - name <- Parse.munch1 Char.isAlphaNum - return $ case name of - "Simple" -> Simple - "Configure" -> Configure - "Custom" -> Custom - "Make" -> Make - _ -> UnknownBuildType name - --- --------------------------------------------------------------------------- --- The Library type - -data Library = Library { - exposedModules :: [String], - libBuildInfo :: BuildInfo - } - deriving (Show, Eq, Read) - -instance Monoid Library where - mempty = nullLibrary - mappend = unionLibrary - -emptyLibrary :: Library -emptyLibrary = Library [] emptyBuildInfo - -nullLibrary :: Library -nullLibrary = Library [] nullBuildInfo - --- |does this package have any libraries? -hasLibs :: PackageDescription -> Bool -hasLibs p = maybe False (buildable . libBuildInfo) (library p) - --- |'Maybe' version of 'hasLibs' -maybeHasLibs :: PackageDescription -> Maybe Library -maybeHasLibs p = - library p >>= \lib -> if buildable (libBuildInfo lib) - then Just lib - else Nothing - --- |If the package description has a library section, call the given --- function with the library build info as argument. -withLib :: PackageDescription -> a -> (Library -> IO a) -> IO a -withLib pkg_descr a f = - maybe (return a) f (maybeHasLibs pkg_descr) - --- |Get all the module names from the libraries in this package -libModules :: PackageDescription -> [String] -libModules PackageDescription{library=lib} - = maybe [] exposedModules lib - ++ maybe [] (otherModules . libBuildInfo) lib - -unionLibrary :: Library -> Library -> Library -unionLibrary l1 l2 = - l1 { exposedModules = combine exposedModules - , libBuildInfo = unionBuildInfo (libBuildInfo l1) (libBuildInfo l2) - } - where combine f = f l1 ++ f l2 - --- --------------------------------------------------------------------------- --- The Executable type - -data Executable = Executable { - exeName :: String, - modulePath :: FilePath, - buildInfo :: BuildInfo - } - deriving (Show, Read, Eq) - -instance Monoid Executable where - mempty = nullExecutable - mappend = unionExecutable - -emptyExecutable :: Executable -emptyExecutable = Executable { - exeName = "", - modulePath = "", - buildInfo = emptyBuildInfo - } - -nullExecutable :: Executable -nullExecutable = emptyExecutable { buildInfo = nullBuildInfo } - --- |does this package have any executables? -hasExes :: PackageDescription -> Bool -hasExes p = any (buildable . buildInfo) (executables p) - --- | Perform the action on each buildable 'Executable' in the package --- description. -withExe :: PackageDescription -> (Executable -> IO a) -> IO () -withExe pkg_descr f = - sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] - --- |Get all the module names from the exes in this package -exeModules :: PackageDescription -> [String] -exeModules PackageDescription{executables=execs} - = concatMap (otherModules . buildInfo) execs - -unionExecutable :: Executable -> Executable -> Executable -unionExecutable e1 e2 = - e1 { exeName = combine exeName - , modulePath = combine modulePath - , buildInfo = unionBuildInfo (buildInfo e1) (buildInfo e2) - } - where combine f = case (f e1, f e2) of - ("","") -> "" - ("", x) -> x - (x, "") -> x - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - --- --------------------------------------------------------------------------- --- The BuildInfo type - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - buildable :: Bool, -- ^ component is buildable here - buildTools :: [Dependency], -- ^ tools needed to build this bit - cppOptions :: [String], -- ^ options for pre-processing Haskell code - ccOptions :: [String], -- ^ options for C compiler - ldOptions :: [String], -- ^ options for linker - pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - cSources :: [FilePath], - hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy - otherModules :: [String], -- ^ non-exposed or non-main modules - extensions :: [Extension], - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - extraLibDirs :: [String], - includeDirs :: [FilePath], -- ^directories to find .h files - includes :: [FilePath], -- ^ The .h files to be found in includeDirs - installIncludes :: [FilePath], -- ^ .h files to install with the package - options :: [(CompilerFlavor,[String])], - ghcProfOptions :: [String], - ghcSharedOptions :: [String], - customFieldsBI :: [(String,String)] -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - } - deriving (Show,Read,Eq) - -instance Monoid BuildInfo where - mempty = nullBuildInfo - mappend = unionBuildInfo - -nullBuildInfo :: BuildInfo -nullBuildInfo = BuildInfo { - buildable = True, - buildTools = [], - cppOptions = [], - ccOptions = [], - ldOptions = [], - pkgconfigDepends = [], - frameworks = [], - cSources = [], - hsSourceDirs = [], - otherModules = [], - extensions = [], - extraLibs = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - installIncludes = [], - options = [], - ghcProfOptions = [], - ghcSharedOptions = [], - customFieldsBI = [] - } - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = nullBuildInfo - --- | The 'BuildInfo' for the library (if there is one and it's buildable) and --- all the buildable executables. Useful for gathering dependencies. -allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] - , let bi = libBuildInfo lib - , buildable bi ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe - , buildable bi ] - -type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) - --- |Select options for a particular Haskell compiler. -hcOptions :: CompilerFlavor -> BuildInfo -> [String] -hcOptions hc bi = [ opt | (hc',opts) <- options bi - , hc' == hc - , opt <- opts ] - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) - } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = unionBuildInfo bi (libBuildInfo lib)}) - updateLibrary Nothing mb_lib = mb_lib - - --the lib only exists in the buildinfo file. FIX: Is this - --wrong? If there aren't any exposedModules, then the library - --won't build anyway. add to sanity checker? - updateLibrary (Just bi) Nothing = Just emptyLibrary{libBuildInfo=bi} - - updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^libst with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = unionBuildInfo bi (buildInfo exe)} : exes - | otherwise = exe : updateExecutable exe_bi' exes - -unionBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo -unionBuildInfo b1 b2 - = BuildInfo { - buildable = buildable b1 && buildable b2, - buildTools = combineNub buildTools, - cppOptions = combine cppOptions, - ccOptions = combine ccOptions, - ldOptions = combine ldOptions, - pkgconfigDepends = combineNub pkgconfigDepends, - frameworks = combineNub frameworks, - cSources = combineNub cSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - extensions = combineNub extensions, - extraLibs = combine extraLibs, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - installIncludes = combineNub installIncludes, - options = combine options, - ghcProfOptions = combine ghcProfOptions, - ghcSharedOptions = combine ghcSharedOptions, - customFieldsBI = combine customFieldsBI - } - where - combine f = f b1 ++ f b2 - combineNub f = nub (combine f) - --- --------------------------------------------------------------------------- --- The GenericPackageDescription type - -data GenericPackageDescription = - GenericPackageDescription { - packageDescription :: PackageDescription, - genPackageFlags :: [Flag], - condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), - condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] - } - deriving (Show) - -instance Package GenericPackageDescription where - packageId = packageId . packageDescription - -{- --- XXX: I think we really want a PPrint or Pretty or ShowPretty class. -instance Show GenericPackageDescription where - show (GenericPackageDescription pkg flgs mlib exes) = - showPackageDescription pkg ++ "\n" ++ - (render $ vcat $ map ppFlag flgs) ++ "\n" ++ - render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib) - ++ "\n" ++ - (render $ vcat $ - map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes) - where - ppFlag (MkFlag name desc dflt) = - showStanza ("Flag " ++ name) - ((if (null desc) then empty else - text ("Description: " ++ desc)) $+$ - text ("Default: " ++ show dflt)) - showDeps = fsep . punctuate comma . map showDependency - showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace --} - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data Flag = MkFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - } - deriving Show - --- | A 'FlagName' is the name of a user-defined configuration flag -newtype FlagName = FlagName String - deriving (Eq, Ord, Show, Read) - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- -type FlagAssignment = [(FlagName, Bool)] - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | Flag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show) - ---instance Text ConfVar where --- disp (OS os) = "os(" ++ display os ++ ")" --- disp (Arch arch) = "arch(" ++ display arch ++ ")" --- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")" --- disp (Impl c v) = "impl(" ++ display c --- ++ " " ++ display v ++ ")" - --- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving Show - ---instance Text c => Text (Condition c) where --- disp (Var x) = text (show x) --- disp (Lit b) = text (show b) --- disp (CNot c) = char '!' <> parens (ppCond c) --- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2] --- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2] - -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [( Condition v - , CondTree v c a - , Maybe (CondTree v c a))] - } - deriving Show - ---instance (Text v, Text c) => Text (CondTree v c a) where --- disp (CondNode _dat cs ifs) = --- (text "build-depends: " <+> --- disp cs) --- $+$ --- (vcat $ map ppIf ifs) --- where --- ppIf (c,thenTree,mElseTree) = --- ((text "if" <+> ppCond c <> colon) $$ --- nest 2 (ppCondTree thenTree disp)) --- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp)) --- mElseTree) - -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | Flag f <- freeVars' t ] - where - freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -{-# DEPRECATED setupMessage "it's exported from the Utils module now" #-} -setupMessage :: Verbosity -> String -> PackageDescription -> IO () -setupMessage verbosity msg pkg_descr = - notice verbosity (msg ++ ' ': display (packageId pkg_descr) ++ "...") - --- ----------------------------------------------------------------------------- --- The PackageDescription type - -pkgDescrFieldDescrs :: [FieldDescr PackageDescription] -pkgDescrFieldDescrs = - [ simpleField "name" - text parsePackageName - packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) - , simpleField "version" - disp parse - packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) - , simpleField "cabal-version" - disp parse - descCabalVersion (\v pkg -> pkg{descCabalVersion=v}) - , simpleField "build-type" - (maybe empty disp) (fmap Just parse) - buildType (\t pkg -> pkg{buildType=t}) - , simpleField "license" - disp parseLicenseQ - license (\l pkg -> pkg{license=l}) - , simpleField "license-file" - showFilePath parseFilePathQ - licenseFile (\l pkg -> pkg{licenseFile=l}) - , simpleField "copyright" - showFreeText (Parse.munch (const True)) - copyright (\val pkg -> pkg{copyright=val}) - , simpleField "maintainer" - showFreeText (Parse.munch (const True)) - maintainer (\val pkg -> pkg{maintainer=val}) - , commaListField "build-depends" - disp parse - buildDepends (\xs pkg -> pkg{buildDepends=xs}) - , simpleField "stability" - showFreeText (Parse.munch (const True)) - stability (\val pkg -> pkg{stability=val}) - , simpleField "homepage" - showFreeText (Parse.munch (const True)) - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText (Parse.munch (const True)) - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "synopsis" - showFreeText (Parse.munch (const True)) - synopsis (\val pkg -> pkg{synopsis=val}) - , simpleField "description" - showFreeText (Parse.munch (const True)) - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText (Parse.munch (const True)) - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText (Parse.munch (const True)) - author (\val pkg -> pkg{author=val}) - , listField "tested-with" - showTestedWith parseTestedWithQ - testedWith (\val pkg -> pkg{testedWith=val}) - , listField "data-files" - showFilePath parseFilePathQ - dataFiles (\val pkg -> pkg{dataFiles=val}) - , simpleField "data-dir" - showFilePath parseFilePathQ - dataDir (\val pkg -> pkg{dataDir=val}) - , listField "extra-source-files" - showFilePath parseFilePathQ - extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) - , listField "extra-tmp-files" - showFilePath parseFilePathQ - extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) - ] - --- | Store any fields beginning with "x-" in the customFields field of --- a PackageDescription. All other fields will generate a warning. -storeXFieldsPD :: UnrecFieldParser PackageDescription -storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = (f,val):(customFieldsPD pkg) } -storeXFieldsPD _ _ = Nothing - --- --------------------------------------------------------------------------- --- The Library type - -libFieldDescrs :: [FieldDescr Library] -libFieldDescrs = map biToLib binfoFieldDescrs - ++ [ - listField "exposed-modules" text parseModuleNameQ - exposedModules (\mods lib -> lib{exposedModules=mods}) - ] - where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) - -storeXFieldsLib :: UnrecFieldParser Library -storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = - Just $ l {libBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi) }} -storeXFieldsLib _ _ = Nothing - --- --------------------------------------------------------------------------- --- The Executable type - - -executableFieldDescrs :: [FieldDescr Executable] -executableFieldDescrs = - [ -- note ordering: configuration must come first, for - -- showPackageDescription. - simpleField "executable" - showToken parseTokenQ - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" - showFilePath parseFilePathQ - modulePath (\xs exe -> exe{modulePath=xs}) - ] - ++ map biToExe binfoFieldDescrs - where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) - -storeXFieldsExe :: UnrecFieldParser Executable -storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = - Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} -storeXFieldsExe _ _ = Nothing - --- --------------------------------------------------------------------------- --- The BuildInfo type - - -binfoFieldDescrs :: [FieldDescr BuildInfo] -binfoFieldDescrs = - [ boolField "buildable" - buildable (\val binfo -> binfo{buildable=val}) - , commaListField "build-tools" - disp parseBuildTool - buildTools (\xs binfo -> binfo{buildTools=xs}) - , listField "cpp-options" - showToken parseTokenQ - cppOptions (\val binfo -> binfo{cppOptions=val}) - , listField "cc-options" - showToken parseTokenQ - ccOptions (\val binfo -> binfo{ccOptions=val}) - , listField "ld-options" - showToken parseTokenQ - ldOptions (\val binfo -> binfo{ldOptions=val}) - , commaListField "pkgconfig-depends" - disp parsePkgconfigDependency - pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) - , listField "frameworks" - showToken parseTokenQ - frameworks (\val binfo -> binfo{frameworks=val}) - , listField "c-sources" - showFilePath parseFilePathQ - cSources (\paths binfo -> binfo{cSources=paths}) - , listField "extensions" - disp parseExtensionQ - extensions (\exts binfo -> binfo{extensions=exts}) - , listField "extra-libraries" - showToken parseTokenQ - extraLibs (\xs binfo -> binfo{extraLibs=xs}) - , listField "extra-lib-dirs" - showFilePath parseFilePathQ - extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) - , listField "includes" - showFilePath parseFilePathQ - includes (\paths binfo -> binfo{includes=paths}) - , listField "install-includes" - showFilePath parseFilePathQ - installIncludes (\paths binfo -> binfo{installIncludes=paths}) - , listField "include-dirs" - showFilePath parseFilePathQ - includeDirs (\paths binfo -> binfo{includeDirs=paths}) - , listField "hs-source-dirs" - showFilePath parseFilePathQ - hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) - , listField "other-modules" - text parseModuleNameQ - otherModules (\val binfo -> binfo{otherModules=val}) - , listField "ghc-prof-options" - text parseTokenQ - ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) - , listField "ghc-shared-options" - text parseTokenQ - ghcProfOptions (\val binfo -> binfo{ghcSharedOptions=val}) - , optsField "ghc-options" GHC - options (\path binfo -> binfo{options=path}) - , optsField "hugs-options" Hugs - options (\path binfo -> binfo{options=path}) - , optsField "nhc98-options" NHC - options (\path binfo -> binfo{options=path}) - , optsField "jhc-options" JHC - options (\path binfo -> binfo{options=path}) - ] - -storeXFieldsBI :: UnrecFieldParser BuildInfo -storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } -storeXFieldsBI _ _ = Nothing - ------------------------------------------------------------------------------- - -flagFieldDescrs :: [FieldDescr Flag] -flagFieldDescrs = - [ simpleField "description" - showFreeText (Parse.munch (const True)) - flagDescription (\val fl -> fl{ flagDescription = val }) - , boolField "default" - flagDefault (\val fl -> fl{ flagDefault = val }) - ] - --- --------------------------------------------------------------- --- Parsing - --- | Given a parser and a filename, return the parse of the file, --- after checking if the file exists. -readAndParseFile :: (FilePath -> IO String) - -> (String -> ParseResult a) - -> Verbosity - -> FilePath -> IO a -readAndParseFile readFile' parser verbosity fpath = do - exists <- doesFileExist fpath - when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") - str <- readFile' fpath - case parser str of - ParseFailed e -> do - let (line, message) = locatedErrorMsg e - dieWithLocation fpath line message - ParseOk warnings x -> do - mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings - return x - -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -readHookedBuildInfo = - readAndParseFile readFile parseHookedBuildInfo - --- |Parse the given package file. -readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readPackageDescription = - readAndParseFile readUTF8File parsePackageDescription - -stanzas :: [Field] -> [[Field]] -stanzas [] = [] -stanzas (f:fields) = (f:this) : stanzas rest - where - (this, rest) = break isStanzaHeader fields - -isStanzaHeader :: Field -> Bool -isStanzaHeader (F _ f _) = f == "executable" -isStanzaHeader _ = False - ------------------------------------------------------------------------------- - - -mapSimpleFields :: (Field -> ParseResult Field) -> [Field] - -> ParseResult [Field] -mapSimpleFields f fs = mapM walk fs - where - walk fld@(F _ _ _) = f fld - walk (IfBlock l c fs1 fs2) = do - fs1' <- mapM walk fs1 - fs2' <- mapM walk fs2 - return (IfBlock l c fs1' fs2') - walk (Section ln n l fs1) = do - fs1' <- mapM walk fs1 - return (Section ln n l fs1') - --- prop_isMapM fs = mapSimpleFields return fs == return fs - - --- names of fields that represents dependencies, thus consrca -constraintFieldNames :: [String] -constraintFieldNames = ["build-depends"] - --- Possible refactoring would be to have modifiers be explicit about what --- they add and define an accessor that specifies what the dependencies --- are. This way we would completely reuse the parsing knowledge from the --- field descriptor. -parseConstraint :: Field -> ParseResult [Dependency] -parseConstraint (F l n v) - | n == "build-depends" = runP l n (parseCommaList parse) v -parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" - -{- -headerFieldNames :: [String] -headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) - . map fieldName $ pkgDescrFieldDescrs --} - -libFieldNames :: [String] -libFieldNames = map fieldName libFieldDescrs - ++ buildInfoNames ++ constraintFieldNames - --- exeFieldNames :: [String] --- exeFieldNames = map fieldName executableFieldDescrs --- ++ buildInfoNames - -buildInfoNames :: [String] -buildInfoNames = map fieldName binfoFieldDescrs - ++ map fst deprecatedFieldsBuildInfo - --- A minimal implementation of the StateT monad transformer to avoid depending --- on the 'mtl' package. -newtype StT s m a = StT { runStT :: s -> m (a,s) } - -instance Monad m => Monad (StT s m) where - return a = StT (\s -> return (a,s)) - StT f >>= g = StT $ \s -> do - (a,s') <- f s - runStT (g a) s' - -get :: Monad m => StT s m s -get = StT $ \s -> return (s, s) - -modify :: Monad m => (s -> s) -> StT s m () -modify f = StT $ \s -> return ((),f s) - -lift :: Monad m => m a -> StT s m a -lift m = StT $ \s -> m >>= \a -> return (a,s) - -evalStT :: Monad m => StT s m a -> s -> m a -evalStT st s = runStT st s >>= return . fst - --- Our monad for parsing a list/tree of fields. --- --- The state represents the remaining fields to be processed. -type PM a = StT [Field] ParseResult a - - - --- return look-ahead field or nothing if we're at the end of the file -peekField :: PM (Maybe Field) -peekField = get >>= return . listToMaybe - --- Unconditionally discard the first field in our state. Will error when it --- reaches end of file. (Yes, that's evil.) -skipField :: PM () -skipField = modify tail - --- | Parses the given file into a 'GenericPackageDescription'. --- --- In Cabal 1.2 the syntax for package descriptions was changed to a format --- with sections and possibly indented property descriptions. -parsePackageDescription :: String -> ParseResult GenericPackageDescription -parsePackageDescription file = do - let tabs = findIndentTabs file - - fields0 <- readFields file `catchParseError` \err -> - case err of - -- In case of a TabsError report them all at once. - TabsError tabLineNo -> reportTabsError - -- but only report the ones including and following - -- the one that caused the actual error - [ t | t@(lineNo',_) <- tabs - , lineNo' >= tabLineNo ] - _ -> parseFail err - - let cabalVersionNeeded = - head $ [ versionRange - | Just versionRange <- [ simpleParse v - | F _ "cabal-version" v <- fields0 ] ] - ++ [AnyVersion] - handleFutureVersionParseFailure cabalVersionNeeded $ do - - let sf = sectionizeFields fields0 - fields <- mapSimpleFields deprecField sf - - flip evalStT fields $ do - hfs <- getHeader [] - pkg <- lift $ parseFields pkgDescrFieldDescrs storeXFieldsPD emptyPackageDescription hfs - (flags, mlib, exes) <- getBody - warnIfRest - when (not (oldSyntax fields0)) $ - maybeWarnCabalVersion pkg - checkForUndefinedFlags flags mlib exes - return (GenericPackageDescription pkg flags mlib exes) - - where - oldSyntax flds = all isSimpleField flds - reportTabsError tabs = - syntaxError (fst (head tabs)) $ - "Do not use tabs for indentation (use spaces instead)\n" - ++ " Tabs were used at (line,column): " ++ show tabs - maybeWarnCabalVersion pkg = - when (packageName pkg /= "Cabal" -- supress warning for Cabal - && isAnyVersion (descCabalVersion pkg)) $ - lift $ warning $ - "A package using section syntax should require\n" - ++ "\"Cabal-Version: >= 1.2\" or equivalent." - - handleFutureVersionParseFailure cabalVersionNeeded parseBody = - (unless versionOk (warning message) >> parseBody) - `catchParseError` \parseError -> case parseError of - TabsError _ -> parseFail parseError - _ | versionOk -> parseFail parseError - | otherwise -> fail message - where versionOk = cabalVersion `withinRange` cabalVersionNeeded - message = "This package requires Cabal version: " - ++ display cabalVersionNeeded - - -- "Sectionize" an old-style Cabal file. A sectionized file has: - -- - -- * all global fields at the beginning, followed by - -- * all flag declarations, followed by - -- * an optional library section, and - -- * an arbitrary number of executable sections. - -- - -- The current implementatition just gathers all library-specific fields - -- in a library section and wraps all executable stanzas in an executable - -- section. - sectionizeFields :: [Field] -> [Field] - sectionizeFields fs - | oldSyntax fs = - let - -- "build-depends" is a local field now. To be backwards - -- compatible, we still allow it as a global field in old-style - -- package description files and translate it to a local field by - -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . fName) fs - (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 - - (deps, libfs) = partition ((== "build-depends") . fName) - libfs0 - - exes = unfoldr toExe exes0 - toExe [] = Nothing - toExe (F l e n : r) - | e == "executable" = - let (efs, r') = break ((=="executable") . fName) r - in Just (Section l "executable" n (deps ++ efs), r') - toExe _ = bug "unexpeced input to 'toExe'" - in - hdr ++ - (if null libfs then [] - else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) - ++ exes - | otherwise = fs - - isSimpleField (F _ _ _) = True - isSimpleField _ = False - - -- warn if there's something at the end of the file - warnIfRest :: PM () - warnIfRest = do - s <- get - case s of - [] -> return () - _ -> lift $ warning "Ignoring trailing declarations." -- add line no. - - -- all simple fields at the beginning of the file are (considered) header - -- fields - getHeader :: [Field] -> PM [Field] - getHeader acc = peekField >>= \mf -> case mf of - Just f@(F _ _ _) -> skipField >> getHeader (f:acc) - _ -> return (reverse acc) - - -- - -- body ::= flag* { library | executable }+ -- at most one lib - -- - -- The body consists of an optional sequence of flag declarations and after - -- that an arbitrary number of executables and an optional library. The - -- order of the latter doesn't play a role. - getBody :: PM ([Flag] - ,Maybe (CondTree ConfVar [Dependency] Library) - ,[(String, CondTree ConfVar [Dependency] Executable)]) - getBody = do - mf <- peekField - case mf of - Just (Section _ sn _label _fields) - | sn == "flag" -> do - -- don't skipField here. it's simpler to let getFlags do it - -- itself - flags <- getFlags [] - (lib, exes) <- getLibOrExe - return (flags, lib, exes) - | otherwise -> do - (lib,exes) <- getLibOrExe - return ([], lib, exes) - Nothing -> do lift $ warning "No library or executable specified" - return ([], Nothing, []) - Just f -> lift $ syntaxError (lineNo f) $ - "Construct not supported at this position: " ++ show f - - -- - -- flags ::= "flag:" name { flag_prop } - -- - getFlags :: [Flag] -> StT [Field] ParseResult [Flag] - getFlags acc = peekField >>= \mf -> case mf of - Just (Section _ sn sl fs) - | sn == "flag" -> do - fl <- lift $ parseFields - flagFieldDescrs - warnUnrec - (MkFlag (FlagName (lowercase sl)) "" True) - fs - skipField >> getFlags (fl : acc) - _ -> return (reverse acc) - - getLibOrExe :: PM (Maybe (CondTree ConfVar [Dependency] Library) - ,[(String, CondTree ConfVar [Dependency] Executable)]) - getLibOrExe = peekField >>= \mf -> case mf of - Just (Section n sn sl fs) - | sn == "executable" -> do - when (null sl) $ lift $ - syntaxError n "'executable' needs one argument (the executable's name)" - exename <- lift $ runP n "executable" parseTokenQ sl - flds <- collectFields parseExeFields fs - skipField - (lib, exes) <- getLibOrExe - return (lib, exes ++ [(exename, flds)]) - | sn == "library" -> do - when (not (null sl)) $ lift $ - syntaxError n "'library' expects no argument" - flds <- collectFields parseLibFields fs - skipField - (lib, exes) <- getLibOrExe - return (maybe (Just flds) - (const (error "Multiple libraries specified")) - lib - , exes) - | otherwise -> do - lift $ warning $ "Unknown section type: " ++ sn ++ " ignoring..." - return (Nothing, []) -- yep - Just x -> lift $ syntaxError (lineNo x) $ "Section expected." - Nothing -> return (Nothing, []) - - -- extracts all fields in a block, possibly add dependencies to the - -- guard condition - collectFields :: ([Field] -> PM a) -> [Field] - -> PM (CondTree ConfVar [Dependency] a) - collectFields parser allflds = do - a <- parser dataFlds - deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds - ifs <- mapM processIfs condFlds - return (CondNode a deps ifs) - where - (depFlds, dataFlds) = partition isConstraint simplFlds - simplFlds = [ F l n v | F l n v <- allflds ] - condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] - isConstraint (F _ n _) = n `elem` constraintFieldNames - isConstraint _ = False - processIfs (IfBlock l c t e) = do - cnd <- lift $ runP l "if" parseCondition c - t' <- collectFields parser t - e' <- case e of - [] -> return Nothing - es -> do fs <- collectFields parser es - return (Just fs) - return (cnd, t', e') - processIfs _ = bug "processIfs called with wrong field type" - - parseLibFields :: [Field] -> StT s ParseResult Library - parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary - - parseExeFields :: [Field] -> StT s ParseResult Executable - parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable - - checkForUndefinedFlags :: - [Flag] -> - Maybe (CondTree ConfVar [Dependency] Library) -> - [(String, CondTree ConfVar [Dependency] Executable)] -> - PM () - checkForUndefinedFlags flags mlib exes = do - let definedFlags = map flagName flags - maybe (return ()) (checkCondTreeFlags definedFlags) mlib - mapM_ (checkCondTreeFlags definedFlags . snd) exes - - checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () - checkCondTreeFlags definedFlags ct = do - let fv = nub $ freeVars ct - when (not . all (`elem` definedFlags) $ fv) $ - fail $ "These flags are used without having been defined: " - ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] - - --- | Parse a list of fields, given a list of field descriptions, --- a structure to accumulate the parsed fields, and a function --- that can decide what to do with fields which don't match any --- of the field descriptions. -parseFields :: [FieldDescr a] -- ^ list of parseable fields - -> UnrecFieldParser a -- ^ possibly do something with - -- unrecognized fields - -> a -- ^ accumulator - -> [Field] -- ^ fields to be parsed - -> ParseResult a -parseFields descrs unrec ini fields = - do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields - when (not (null unknowns)) $ do - warning $ render $ - text "Unknown fields:" <+> - commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") - (reverse unknowns)) - $+$ - text "Fields allowed in this section:" $$ - nest 4 (commaSep $ map fieldName descrs) - return a - where - commaSep = fsep . punctuate comma . map text - -parseField :: [FieldDescr a] -- ^ list of parseable fields - -> UnrecFieldParser a -- ^ possibly do something with - -- unrecognized fields - -> (a,[(Int,String)]) -- ^ accumulated result and warnings - -> Field -- ^ the field to be parsed - -> ParseResult (a, [(Int,String)]) -parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) - | name == f = parser line val a >>= \a' -> return (a',us) - | otherwise = parseField fields unrec (a,us) (F line f val) -parseField [] unrec (a,us) (F l f val) = return $ - case unrec (f,val) a of -- no fields matched, see if the 'unrec' - Just a' -> (a',us) -- function wants to do anything with it - Nothing -> (a, ((l,f):us)) -parseField _ _ _ _ = bug "'parseField' called on a non-field" - -deprecatedFields :: [(String,String)] -deprecatedFields = - deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo - -deprecatedFieldsPkgDescr :: [(String,String)] -deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] - -deprecatedFieldsBuildInfo :: [(String,String)] -deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] - --- Handle deprecated fields -deprecField :: Field -> ParseResult Field -deprecField (F line fld val) = do - fld' <- case lookup fld deprecatedFields of - Nothing -> return fld - Just newName -> do - warning $ "The field \"" ++ fld - ++ "\" is deprecated, please use \"" ++ newName ++ "\"" - return newName - return (F line fld' val) -deprecField _ = bug "'deprecField' called on a non-field" - - -parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo -parseHookedBuildInfo inp = do - fields <- readFields inp - let ss@(mLibFields:exes) = stanzas fields - mLib <- parseLib mLibFields - biExes <- mapM parseExe (maybe ss (const exes) mLib) - return (mLib, biExes) - where - parseLib :: [Field] -> ParseResult (Maybe BuildInfo) - parseLib (bi@((F _ inFieldName _):_)) - | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) - parseLib _ = return Nothing - - parseExe :: [Field] -> ParseResult (String, BuildInfo) - parseExe ((F line inFieldName mName):bi) - | lowercase inFieldName == "executable" - = do bis <- parseBI bi - return (mName, bis) - | otherwise = syntaxError line "expecting 'executable' at top of stanza" - parseExe (_:_) = bug "`parseExe' called on a non-field" - parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" - - parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st - --- | Parse a configuration condition from a string. -parseCondition :: Parse.ReadP r (Condition ConfVar) -parseCondition = condOr - where - condOr = Parse.sepBy1 condAnd (oper "||") >>= return . foldl1 COr - condAnd = Parse.sepBy1 cond (oper "&&")>>= return . foldl1 CAnd - cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond - +++ archCond +++ flagCond +++ implCond ) - inparens = Parse.between (Parse.char '(' >> sp) (sp >> Parse.char ')' >> sp) - notCond = Parse.char '!' >> sp >> cond >>= return . CNot - osCond = Parse.string "os" >> sp >> inparens osIdent >>= return . Var - archCond = Parse.string "arch" >> sp >> inparens archIdent >>= return . Var - flagCond = Parse.string "flag" >> sp >> inparens flagIdent >>= return . Var - implCond = Parse.string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parse - archIdent = fmap Arch parse - osIdent = fmap OS parse - flagIdent = fmap (Flag . FlagName . lowercase) (Parse.munch1 isIdentChar) - isIdentChar c = Char.isAlphaNum c || c == '_' || c == '-' - oper s = sp >> Parse.string s >> sp - sp = Parse.skipSpaces - implIdent = do i <- parse - vr <- sp >> Parse.option AnyVersion parse - return $ Impl i vr - --- --------------------------------------------------------------------------- --- Pretty printing - -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) - -showPackageDescription :: PackageDescription -> String -showPackageDescription pkg = render $ - ppFields pkg pkgDescrFieldDescrs $$ - ppCustomFields (customFieldsPD pkg) $$ - (case library pkg of - Nothing -> empty - Just lib -> ppFields lib libFieldDescrs) $$ - vcat (map ppExecutable (executables pkg)) - where - ppExecutable exe = space $$ ppFields exe executableFieldDescrs - -ppCustomFields :: [(String,String)] -> Doc -ppCustomFields flds = vcat (map ppCustomField flds) - -ppCustomField :: (String,String) -> Doc -ppCustomField (name,val) = text name <> colon <+> showFreeText val - -writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath pbi = writeFile fpath (showHookedBuildInfo pbi) - -showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bi) = render $ - (case mb_lib_bi of - Nothing -> empty - Just bi -> ppFields bi binfoFieldDescrs) $$ - vcat (map ppExeBuildInfo ex_bi) - where - ppExeBuildInfo (name, bi) = - space $$ - text "executable:" <+> text name $$ - ppFields bi binfoFieldDescrs $$ - ppCustomFields (customFieldsBI bi) - --- replace all tabs used as indentation with whitespace, also return where --- tabs were found -findIndentTabs :: String -> [(Int,Int)] -findIndentTabs = concatMap checkLine - . zip [1..] - . lines - where - checkLine (lineno, l) = - let (indent, _content) = span Char.isSpace l - tabCols = map fst . filter ((== '\t') . snd) . zip [0..] - addLineNo = map (\col -> (lineno,col)) - in addLineNo (tabCols indent) - ---test_findIndentTabs = findIndentTabs $ unlines $ --- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] - -bug :: String -> a -bug msg = error $ msg ++ ". Consider this a bug." +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the data structure for the @.cabal@ file format. There are +-- several parts to this structure. It has top level info and then 'Library' +-- and 'Executable' sections each of which have associated 'BuildInfo' data +-- that's used to build the library or exe. To further complicate things there +-- is both a 'PackageDescription' and a 'GenericPackageDescription'. This +-- distinction relates to cabal configurations. When we initially read a +-- @.cabal@ file we get a 'GenericPackageDescription' which has all the +-- conditional sections. Before actually building a package we have to decide +-- on each conditional. Once we've done that we get a 'PackageDescription'. +-- It was done this way initially to avoid breaking too much stuff when the +-- feature was introduced. It could probably do with being rationalised at some +-- point to make it simpler. + +{- 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.PackageDescription ( + -- * Package descriptions + PackageDescription(..), + emptyPackageDescription, + BuildType(..), + knownBuildTypes, + + -- ** Libraries + Library(..), + emptyLibrary, + withLib, + hasLibs, + libModules, + + -- ** Executables + Executable(..), + emptyExecutable, + withExe, + hasExes, + exeModules, + + -- * Build information + BuildInfo(..), + emptyBuildInfo, + allBuildInfo, + hcOptions, + + -- ** Supplementary build information + HookedBuildInfo, + emptyHookedBuildInfo, + updatePackageDescription, + + -- * package configuration + GenericPackageDescription(..), + Flag(..), FlagName(..), FlagAssignment, + CondTree(..), ConfVar(..), Condition(..), + + -- * Source repositories + SourceRepo(..), RepoKind(..), RepoType(..), + ) where + +import Data.List (nub) +import Data.Monoid (Monoid(mempty, mappend)) +import Text.PrettyPrint.HughesPJ as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Data.Char as Char (isAlphaNum, toLower) + +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) + , Dependency, Package(..) ) +import Distribution.ModuleName (ModuleName) +import Distribution.Version (Version(Version), VersionRange(AnyVersion)) +import Distribution.License (License(AllRightsReserved)) +import Distribution.Compiler (CompilerFlavor) +import Distribution.System (OS, Arch) +import Distribution.Text + ( Text(..), display ) +import Language.Haskell.Extension (Extension) + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +-- | This data type is the internal representation of the file @pkg.cabal@. +-- It contains two kinds of information about the package: information +-- which is needed for all packages, such as the package name and version, and +-- information which is needed for the simple build system only, such as +-- the compiler options and library name. +-- +data PackageDescription + = PackageDescription { + -- the following are required by all packages: + package :: PackageIdentifier, + license :: License, + licenseFile :: FilePath, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, -- ^A one-line summary of this package + description :: String, -- ^A more verbose description of this package + category :: String, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + buildDepends :: [Dependency], + descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here. + buildType :: Maybe BuildType, + -- components + library :: Maybe Library, + executables :: [Executable], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath] + } + deriving (Show, Read, Eq) + +instance Package PackageDescription where + packageId = package + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageIdentifier (PackageName "") + (Version [] []), + license = AllRightsReserved, + licenseFile = "", + descCabalVersion = AnyVersion, + buildType = Nothing, + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + buildDepends = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + library = Nothing, + executables = [], + dataFiles = [], + dataDir = "", + extraSrcFiles = [], + extraTmpFiles = [] + } + +-- | The type of build system used by this package. +data BuildType + = Simple -- ^ calls @Distribution.Simple.defaultMain@ + | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + | Make -- ^ calls @Distribution.Make.defaultMain@ + | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + | UnknownBuildType String + -- ^ a package that uses an unknown build type cannot actually + -- be built. Doing it this way rather than just giving a + -- parse error means we get better error messages and allows + -- you to inspect the rest of the package description. + deriving (Show, Read, Eq) + +knownBuildTypes :: [BuildType] +knownBuildTypes = [Simple, Configure, Make, Custom] + +instance Text BuildType where + disp (UnknownBuildType other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 Char.isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +-- --------------------------------------------------------------------------- +-- The Library type + +data Library = Library { + exposedModules :: [ModuleName], + libExposed :: Bool, -- ^ Is the lib to be exposed by default? + libBuildInfo :: BuildInfo + } + deriving (Show, Eq, Read) + +instance Monoid Library where + mempty = Library { + exposedModules = mempty, + libExposed = True, + libBuildInfo = mempty + } + mappend a b = Library { + exposedModules = combine exposedModules, + libExposed = libExposed a && libExposed b, -- so False propagates + libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +emptyLibrary :: Library +emptyLibrary = mempty + +-- |does this package have any libraries? +hasLibs :: PackageDescription -> Bool +hasLibs p = maybe False (buildable . libBuildInfo) (library p) + +-- |'Maybe' version of 'hasLibs' +maybeHasLibs :: PackageDescription -> Maybe Library +maybeHasLibs p = + library p >>= \lib -> if buildable (libBuildInfo lib) + then Just lib + else Nothing + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. +withLib :: PackageDescription -> a -> (Library -> IO a) -> IO a +withLib pkg_descr a f = + maybe (return a) f (maybeHasLibs pkg_descr) + +-- |Get all the module names from the libraries in this package +libModules :: PackageDescription -> [ModuleName] +libModules PackageDescription{library=lib} + = maybe [] exposedModules lib + ++ maybe [] (otherModules . libBuildInfo) lib + +-- --------------------------------------------------------------------------- +-- The Executable type + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Show, Read, Eq) + +instance Monoid Executable where + mempty = Executable { + exeName = mempty, + modulePath = mempty, + buildInfo = mempty + } + mappend a b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case (field a, field b) of + ("","") -> "" + ("", x) -> x + (x, "") -> x + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +-- |does this package have any executables? +hasExes :: PackageDescription -> Bool +hasExes p = any (buildable . buildInfo) (executables p) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. +withExe :: PackageDescription -> (Executable -> IO a) -> IO () +withExe pkg_descr f = + sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] + +-- |Get all the module names from the exes in this package +exeModules :: PackageDescription -> [ModuleName] +exeModules PackageDescription{executables=execs} + = concatMap (otherModules . buildInfo) execs + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + +-- Consider refactoring into executable and library versions. +data BuildInfo = BuildInfo { + buildable :: Bool, -- ^ component is buildable here + buildTools :: [Dependency], -- ^ tools needed to build this bit + cppOptions :: [String], -- ^ options for pre-processing Haskell code + ccOptions :: [String], -- ^ options for C compiler + ldOptions :: [String], -- ^ options for linker + pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + cSources :: [FilePath], + hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + extensions :: [Extension], + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + extraLibDirs :: [String], + includeDirs :: [FilePath], -- ^directories to find .h files + includes :: [FilePath], -- ^ The .h files to be found in includeDirs + installIncludes :: [FilePath], -- ^ .h files to install with the package + options :: [(CompilerFlavor,[String])], + ghcProfOptions :: [String], + ghcSharedOptions :: [String], + customFieldsBI :: [(String,String)] -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + } + deriving (Show,Read,Eq) + +instance Monoid BuildInfo where + mempty = BuildInfo { + buildable = True, + buildTools = [], + cppOptions = [], + ccOptions = [], + ldOptions = [], + pkgconfigDepends = [], + frameworks = [], + cSources = [], + hsSourceDirs = [], + otherModules = [], + extensions = [], + extraLibs = [], + extraLibDirs = [], + includeDirs = [], + includes = [], + installIncludes = [], + options = [], + ghcProfOptions = [], + ghcSharedOptions = [], + customFieldsBI = [] + } + mappend a b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combineNub buildTools, + cppOptions = combine cppOptions, + ccOptions = combine ccOptions, + ldOptions = combine ldOptions, + pkgconfigDepends = combineNub pkgconfigDepends, + frameworks = combineNub frameworks, + cSources = combineNub cSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + extensions = combineNub extensions, + extraLibs = combine extraLibs, + extraLibDirs = combineNub extraLibDirs, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + installIncludes = combineNub installIncludes, + options = combine options, + ghcProfOptions = combine ghcProfOptions, + ghcSharedOptions = combine ghcSharedOptions, + customFieldsBI = combine customFieldsBI + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + +emptyBuildInfo :: BuildInfo +emptyBuildInfo = mempty + +-- | The 'BuildInfo' for the library (if there is one and it's buildable) and +-- all the buildable executables. Useful for gathering dependencies. +allBuildInfo :: PackageDescription -> [BuildInfo] +allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] + , let bi = libBuildInfo lib + , buildable bi ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe + , buildable bi ] + +type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) + +emptyHookedBuildInfo :: HookedBuildInfo +emptyHookedBuildInfo = (Nothing, []) + +-- |Select options for a particular Haskell compiler. +hcOptions :: CompilerFlavor -> BuildInfo -> [String] +hcOptions hc bi = [ opt | (hc',opts) <- options bi + , hc' == hc + , opt <- opts ] + +-- ------------------------------------------------------------ +-- * Source repos +-- ------------------------------------------------------------ + +-- | Information about the source revision control system for a package. +-- +-- When specifying a repo it is useful to know the meaning or intention of the +-- information as doing so enables automation. There are two obvious common +-- purposes: one is to find the repo for the latest development version, the +-- other is to find the repo for this specific release. The 'ReopKind' +-- specifies which one we mean (or another custom one). +-- +-- A package can specify one or the other kind or both. Most will specify just +-- a head repo but some may want to specify a repo to reconstruct the sources +-- for this package release. +-- +-- The required information is the 'RepoType' which tells us if it's using +-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are +-- interpreted according to the repo type. +-- +data SourceRepo = SourceRepo { + -- | The kind of repo. This field is required. + repoKind :: RepoKind, + + -- | The type of the source repository system for this repo, eg 'Darcs' or + -- 'Git'. This field is required. + repoType :: Maybe RepoType, + + -- | The location of the repository. For most 'RepoType's this is a URL. + -- This field is required. + repoLocation :: Maybe String, + + -- | 'CVS' can put multiple \"modules\" on one server and requires a + -- module name in addition to the location to identify a particular repo. + -- Logically this is part of the location but unfortunately has to be + -- specified separately. This field is required for the 'CVS' 'RepoType' and + -- should not be given otherwise. + repoModule :: Maybe String, + + -- | The name or identifier of the branch, if any. Many source control + -- systems have the notion of multiple branches in a repo that exist in the + -- same location. For example 'Git' and 'CVS' use this while systems like + -- 'Darcs' use different locations for different branches. This field is + -- optional but should be used if necessary to identify the sources, + -- especially for the 'RepoThis' repo kind. + repoBranch :: Maybe String, + + -- | The tag identify a particular state of the repository. This should be + -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. + -- + repoTag :: Maybe String, + + -- | Some repositories contain multiple projects in different subdirectories + -- This field specifies the subdirectory where this packages sources can be + -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted + -- relative to the root of the repository. This field is optional. If not + -- given the default is \".\" ie no subdirectory. + repoSubdir :: Maybe FilePath +} + deriving (Eq, Read, Show) + +-- | What this repo info is for, what it represents. +-- +data RepoKind = + -- | The repository for the \"head\" or development version of the project. + -- This repo is where we should track the latest development activity or + -- the usual repo people should get to contribute patches. + RepoHead + + -- | The repository containing the sources for this exact package version + -- or release. For this kind of repo a tag should be given to give enough + -- information to re-create the exact sources. + | RepoThis + + | RepoKindUnknown String + deriving (Eq, Ord, Read, Show) + +-- | An enumeration of common source control systems. The fields used in the +-- 'SourceRepo' depend on the type of repo. The tools and methods used to +-- obtain and track the repo depend on the repo type. +-- +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Eq, Ord, Read, Show) + +knownRepoTypes :: [RepoType] +knownRepoTypes = [Darcs, Git, SVN, CVS + ,Mercurial, GnuArch, Bazaar, Monotone] + +repoTypeAliases :: RepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Text RepoKind where + disp RepoHead = Disp.text "head" + disp RepoThis = Disp.text "this" + disp (RepoKindUnknown other) = Disp.text other + + parse = do + name <- ident + return $ case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Text RepoType where + disp (OtherRepoType other) = Disp.text other + disp other = Disp.text (lowercase (show other)) + parse = fmap classifyRepoType ident + +classifyRepoType :: String -> RepoType +classifyRepoType s = + case lookup (lowercase s) repoTypeMap of + Just repoType' -> repoType' + Nothing -> OtherRepoType s + where + repoTypeMap = [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- display repoType' : repoTypeAliases repoType' ] + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + +lowercase :: String -> String +lowercase = map Char.toLower + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription +updatePackageDescription (mb_lib_bi, exe_bi) p + = p{ executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) + } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + + --the lib only exists in the buildinfo file. FIX: Is this + --wrong? If there aren't any exposedModules, then the library + --won't build anyway. add to sanity checker? + updateLibrary (Just bi) Nothing = Just emptyLibrary{libBuildInfo=bi} + + updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeNames updated + updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' + + updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^libst with exeName updated + updateExecutable _ [] = [] + updateExecutable exe_bi'@(name,bi) (exe:exes) + | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes + +-- --------------------------------------------------------------------------- +-- The GenericPackageDescription type + +data GenericPackageDescription = + GenericPackageDescription { + packageDescription :: PackageDescription, + genPackageFlags :: [Flag], + condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] + } + deriving (Show, Eq) + +instance Package GenericPackageDescription where + packageId = packageId . packageDescription + +{- +-- XXX: I think we really want a PPrint or Pretty or ShowPretty class. +instance Show GenericPackageDescription where + show (GenericPackageDescription pkg flgs mlib exes) = + showPackageDescription pkg ++ "\n" ++ + (render $ vcat $ map ppFlag flgs) ++ "\n" ++ + render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib) + ++ "\n" ++ + (render $ vcat $ + map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes) + where + ppFlag (MkFlag name desc dflt manual) = + showStanza ("Flag " ++ name) + ((if (null desc) then empty else + text ("Description: " ++ desc)) $+$ + text ("Default: " ++ show dflt) $+$ + text ("Manual: " ++ show manual)) + showDeps = fsep . punctuate comma . map showDependency + showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace +-} + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq) + +-- | A 'FlagName' is the name of a user-defined configuration flag +newtype FlagName = FlagName String + deriving (Eq, Ord, Show) + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +type FlagAssignment = [(FlagName, Bool)] + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show) + +--instance Text ConfVar where +-- disp (OS os) = "os(" ++ display os ++ ")" +-- disp (Arch arch) = "arch(" ++ display arch ++ ")" +-- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")" +-- disp (Impl c v) = "impl(" ++ display c +-- ++ " " ++ display v ++ ")" + +-- | A boolean expression parameterized over the variable type used. +data Condition c = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq) + +--instance Text c => Text (Condition c) where +-- disp (Var x) = text (show x) +-- disp (Lit b) = text (show b) +-- disp (CNot c) = char '!' <> parens (ppCond c) +-- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2] +-- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2] + +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [( Condition v + , CondTree v c a + , Maybe (CondTree v c a))] + } + deriving (Show, Eq) + +--instance (Text v, Text c) => Text (CondTree v c a) where +-- disp (CondNode _dat cs ifs) = +-- (text "build-depends: " <+> +-- disp cs) +-- $+$ +-- (vcat $ map ppIf ifs) +-- where +-- ppIf (c,thenTree,mElseTree) = +-- ((text "if" <+> ppCond c <> colon) $$ +-- nest 2 (ppCondTree thenTree disp)) +-- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp)) +-- mElseTree) diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -3,11 +3,21 @@ -- Module : Distribution.PackageDescription.Check -- Copyright : Lennart Kolmodin 2008 -- --- Maintainer : Lennart Kolmodin --- Stability : alpha +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- This module provides functionality to check for common mistakes. +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of check so we can see which ones are appropriate to report +-- in different situations. This code gets uses when configuring a package when +-- we consider only basic problems. The higher standard is uses when when +-- preparing a source tarball and by hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. {- All rights reserved. @@ -44,15 +54,22 @@ PackageCheck(..), checkPackage, checkConfiguredPackage, - checkPackageFiles + + -- ** Checking package contents + checkPackageFiles, + checkPackageContent, + CheckPackageContentOps(..), + checkPackageFileNames, ) where import Data.Maybe (isNothing, catMaybes, fromMaybe) import Data.List (sort, group, isPrefixOf) -import Control.Monad (filterM) -import System.Directory (doesFileExist, doesDirectoryExist) +import Control.Monad + ( filterM, liftM ) +import qualified System.Directory as System + ( doesFileExist, doesDirectoryExist ) -import Distribution.PackageDescription hiding (freeVars) +import Distribution.PackageDescription import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Compiler @@ -67,11 +84,15 @@ import Distribution.Version ( Version(..), withinRange ) import Distribution.Package - ( packageName, packageVersion ) + ( PackageName(PackageName), packageName, packageVersion ) import Distribution.Text ( display, simpleParse ) import Language.Haskell.Extension (Extension(..)) -import System.FilePath (takeExtension, isRelative, splitDirectories, ()) +import System.FilePath + ( (), takeExtension, isRelative, isAbsolute + , splitDirectories, splitPath ) +import System.FilePath.Windows as FilePath.Windows + ( isValid ) -- | Results of some kind of failed package check. -- @@ -146,6 +167,7 @@ checkSanity pkg ++ checkFields pkg ++ checkLicense pkg + ++ checkSourceRepos pkg ++ checkGhcOptions pkg ++ checkCCOptions pkg ++ checkPaths pkg @@ -161,7 +183,7 @@ checkSanity pkg = catMaybes [ - check (null . packageName $ pkg) $ + check (null . (\(PackageName n) -> n) . packageName $ pkg) $ PackageBuildImpossible "No 'name' field." , check (null . versionBranch . packageVersion $ pkg) $ @@ -194,7 +216,7 @@ "Duplicate modules in library: " ++ commaSep moduleDuplicates ] - where moduleDuplicates = [ module_ + where moduleDuplicates = [ display module_ | let modules = exposedModules lib ++ otherModules (libBuildInfo lib) , (module_:_:_) <- group (sort modules) ] @@ -219,7 +241,7 @@ ++ commaSep moduleDuplicates ] - where moduleDuplicates = [ module_ + where moduleDuplicates = [ display module_ | let modules = otherModules (buildInfo exe) , (module_:_:_) <- group (sort modules) ] @@ -231,7 +253,14 @@ checkFields pkg = catMaybes [ - check (isNothing (buildType pkg)) $ + check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ + PackageDistInexcusable $ + "Unfortunately, the package name '" ++ display (packageName pkg) + ++ "' is one of the reserved system file names on Windows. Many tools " + ++ "need to convert package names to file names so using this name " + ++ "would cause problems." + + , check (isNothing (buildType pkg)) $ PackageBuildWarning $ "No 'build-type' specified. If you do not need a custom Setup.hs or " ++ "./configure script then use 'build-type: Simple'." @@ -301,19 +330,57 @@ PackageDistSuspicious "A 'license-file' is not specified." ] +checkSourceRepos :: PackageDescription -> [PackageCheck] +checkSourceRepos pkg = + catMaybes $ concat [[ + + case repoKind repo of + RepoKindUnknown kind -> Just $ PackageDistInexcusable $ + quote kind ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" + _ -> Nothing + + , check (repoType repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'type' is a required field." + + , check (repoLocation repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'location' is a required field." + + , check (repoType repo == Just CVS && repoModule repo == Nothing) $ + PackageDistInexcusable + "For a CVS source-repository, the 'module' is a required field." + + , check (repoKind repo == RepoThis && repoTag repo == Nothing) $ + PackageDistInexcusable $ + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." + + , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ + PackageDistInexcusable + "The 'subdir' field of a source-repository must be a relative path." + ] + | repo <- sourceRepos pkg ] + +--TODO: check location looks like a URL for some repo types. + checkGhcOptions :: PackageDescription -> [PackageCheck] checkGhcOptions pkg = catMaybes [ check has_WerrorWall $ PackageDistInexcusable $ - "'ghc-options: -Wall -Werror' makes the package " - ++ "very easy to break with future GHC versions." + "'ghc-options: -Wall -Werror' makes the package very easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. Use just 'ghc-options: -Wall' instead." , check (not has_WerrorWall && has_Werror) $ PackageDistSuspicious $ "'ghc-options: -Werror' makes the package easy to " - ++ "break with future GHC versions." + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings." , checkFlags ["-fasm"] $ PackageDistInexcusable $ @@ -322,7 +389,10 @@ , checkFlags ["-fvia-C"] $ PackageDistSuspicious $ - "'ghc-options: -fvia-C' is usually unnecessary." + "'ghc-options: -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." , checkFlags ["-fhpc"] $ PackageDistInexcusable $ @@ -366,8 +436,8 @@ PackageDistInexcusable $ "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." - , checkFlags ["-optl-Wl,-s"] $ - PackageDistSuspicious $ + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable $ "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" ++ " operating systems. Cabal 1.4 and later automatically strip" ++ " executables. Cabal also has a flag --disable-executable-stripping" @@ -505,6 +575,9 @@ "..":_ -> True _ -> False +--TODO: check for absolute and outside-of-tree paths in extra-src-files, +-- data-files, hs-src-dirs, etc. + -- ------------------------------------------------------------ -- * Checks on the GenericPackageDescription -- ------------------------------------------------------------ @@ -544,27 +617,55 @@ CAnd c1 c2 -> condfv c1 ++ condfv c2 -- ------------------------------------------------------------ --- * Checks in IO +-- * Checks involving files in the package -- ------------------------------------------------------------ --- | Sanity check things that requires IO. It looks at the files in the package --- and expects to find the package unpacked in at the given filepath. +-- | Sanity check things that requires IO. It looks at the files in the +-- package and expects to find the package unpacked in at the given filepath. -- checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] -checkPackageFiles pkg root = do - licenseError <- checkLicenseExists pkg root - setupError <- checkSetupExists pkg root - configureError <- checkConfigureExists pkg root - localPathErrors <- checkLocalPathsExist pkg root +checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg + where + checkFilesIO = CheckPackageContentOps { + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative + } + relative path = root path - return $ catMaybes [licenseError, setupError, configureError] - ++ localPathErrors +-- | A record of operations needed to check the contents of packages. +-- Used by 'checkPackageContent'. +-- +data CheckPackageContentOps m = CheckPackageContentOps { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool + } -checkLicenseExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck) -checkLicenseExists pkg root +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +-- +checkPackageContent :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkPackageContent ops pkg = do + licenseError <- checkLicenseExists ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg + localPathErrors <- checkLocalPathsExist ops pkg + + return $ catMaybes [licenseError, setupError, configureError] + ++ localPathErrors + +checkLicenseExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkLicenseExists ops pkg | null (licenseFile pkg) = return Nothing | otherwise = do - exists <- doesFileExist (root file) + exists <- doesFileExist ops file return $ check (not exists) $ PackageBuildWarning $ "The 'license-file' field refers to the file " ++ quote file @@ -573,24 +674,30 @@ where file = licenseFile pkg -checkSetupExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck) -checkSetupExists _ root = do - hsexists <- doesFileExist (root "Setup.hs") - lhsexists <- doesFileExist (root "Setup.lhs") +checkSetupExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkSetupExists ops _ = do + hsexists <- doesFileExist ops "Setup.hs" + lhsexists <- doesFileExist ops "Setup.lhs" return $ check (not hsexists && not lhsexists) $ PackageDistInexcusable $ "The package is missing a Setup.hs or Setup.lhs script." -checkConfigureExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck) -checkConfigureExists PackageDescription { buildType = Just Configure } root = do - exists <- doesFileExist (root "configure") +checkConfigureExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkConfigureExists ops PackageDescription { buildType = Just Configure } = do + exists <- doesFileExist ops "configure" return $ check (not exists) $ PackageBuildWarning $ "The 'build-type' is 'Configure' but there is no 'configure' script." checkConfigureExists _ _ = return Nothing -checkLocalPathsExist :: PackageDescription -> FilePath -> IO [PackageCheck] -checkLocalPathsExist pkg root = do +checkLocalPathsExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLocalPathsExist ops pkg = do let dirs = [ (dir, kind) | bi <- allBuildInfo pkg , (dir, kind) <- @@ -598,12 +705,103 @@ ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] , isRelative dir ] - missing <- filterM (fmap not . doesDirectoryExist . (root ) . fst) dirs + missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs return [ PackageBuildWarning { explanation = quote (kind ++ ": " ++ dir) ++ " directory does not exist." } | (dir, kind) <- missing ] + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Check the names of all files in a package for portability problems. This +-- should be done for example when creating or validating a package tarball. +-- +checkPackageFileNames :: [FilePath] -> [PackageCheck] +checkPackageFileNames files = + (take 1 . catMaybes . map checkWindowsPath $ files) + ++ (take 1 . catMaybes . map checkTarPath $ files) + -- If we get any of these checks triggering then we're likely to get + -- many, and that's probably not helpful, so return at most one. + +checkWindowsPath :: FilePath -> Maybe PackageCheck +checkWindowsPath path = + check (not $ FilePath.Windows.isValid path') $ + PackageDistInexcusable $ + "Unfortunately, the file " ++ quote path ++ " is not a valid file " + ++ "name on Windows which would cause portability problems for this " + ++ "package. Windows file names cannot contain any of the characters " + ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " + ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + path' = ".\\" ++ path + -- force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +-- +checkTarPath :: FilePath -> Maybe PackageCheck +checkTarPath path + | length path > 255 = Just longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> Just err + Right [] -> Nothing + Right (first:rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_:_) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c + + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " ++ path + longName = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " ++ path + noSplit = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " ++ path + emptyName = PackageDistInexcusable $ + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." -- ------------------------------------------------------------ -- * Utils diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -8,12 +8,15 @@ -- | -- Module : Distribution.Configuration -- Copyright : Thomas Schilling, 2007 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Configurations +-- This is about the cabal configurations feature. It exports +-- 'finalizePackageDescription' and 'flattenPackageDescription' which are +-- functions for converting 'GenericPackageDescription's down to +-- 'PackageDescription's. It has code for working with the tree of conditions +-- and resolving or flattening conditions. {- All rights reserved. @@ -48,9 +51,14 @@ module Distribution.PackageDescription.Configuration ( finalizePackageDescription, flattenPackageDescription, + + -- Utils + parseCondition, + freeVars, ) where -import Distribution.Package (Package, Dependency(..)) +import Distribution.Package + ( PackageName, Package, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(..), PackageDescription(..) , Library(..), Executable(..), BuildInfo(..) @@ -64,8 +72,14 @@ ( CompilerId(CompilerId) ) import Distribution.System ( OS, Arch ) -import Distribution.Simple.Utils (currentDir) +import Distribution.Simple.Utils (currentDir, lowercase) +import Distribution.Text + ( Text(parse) ) +import Distribution.Compat.ReadP as ReadP hiding ( char ) +import qualified Distribution.Compat.ReadP as ReadP ( char ) + +import Data.Char ( isAlphaNum ) import Data.Maybe ( catMaybes, maybeToList ) import Data.List ( nub ) import Data.Map ( Map, fromListWith, toList ) @@ -143,9 +157,34 @@ -- hasLits _ = False -- +-- | Parse a configuration condition from a string. +parseCondition :: ReadP r (Condition ConfVar) +parseCondition = condOr + where + condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd + cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond ) + inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) + notCond = ReadP.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parse + archIdent = fmap Arch parse + osIdent = fmap OS parse + flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = skipSpaces + implIdent = do i <- parse + vr <- sp >> option AnyVersion parse + return $ Impl i vr + ------------------------------------------------------------------------------ -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) -> CondTree v c a -> CondTree w d b mapCondTree fa fc fcnd (CondNode a c ifs) = CondNode (fa a) (fc c) (map g ifs) @@ -164,7 +203,7 @@ -- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for -- clarity. -data DepTestRslt d = DepOk | MissingDeps d +data DepTestRslt d = DepOk | MissingDeps d instance Monoid d => Monoid (DepTestRslt d) where mempty = DepOk @@ -195,7 +234,7 @@ -- -- This would require some sort of SAT solving, though, thus it's not -- implemented unless we really need it. --- +-- resolveWithFlags :: Monoid a => [(FlagName,[Bool])] -- ^ Domain for each flag name, will be tested in order. @@ -203,7 +242,7 @@ -> Arch -- ^ Arch as returned by Distribution.System.buildArch -> CompilerId -- ^ Compiler flavour + version -> [Dependency] -- ^ Additional constraints - -> [CondTree ConfVar [Dependency] a] + -> [CondTree ConfVar [Dependency] a] -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. -> Either [Dependency] -- missing dependencies ([a], [Dependency], FlagAssignment) @@ -212,9 +251,9 @@ case try dom [] of Right r -> Right r Left dbt -> Left $ findShortest dbt - where + where extraConstrs = toDepMap constrs - + -- simplify trees by (partially) evaluating all conditions and converting -- dependencies to dependency maps. simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps @@ -238,16 +277,16 @@ -- either succeeds or returns a binary tree with the missing dependencies -- encountered in each run. Since the tree is constructed lazily, we -- avoid some computation overhead in the successful case. - try [] flags = - let (depss, as) = unzip - . map (simplifyCondTree (env flags)) + try [] flags = + let (depss, as) = unzip + . map (simplifyCondTree (env flags)) $ simplifiedTrees deps = fromDepMap $ leftJoin (mconcat depss) extraConstrs in case (checkDeps deps, deps) of (DepOk, ds) -> Right (as, ds, flags) (MissingDeps mds, _) -> Left (BTN mds) - try ((n, vals):rest) flags = + try ((n, vals):rest) flags = tryAll $ map (\v -> try rest ((n, v):flags)) vals tryAll = foldr mp mz @@ -265,7 +304,7 @@ -- for the error case we inspect our lazy tree of missing dependencies and -- pick the shortest list of missing dependencies findShortest (BTN x) = x - findShortest (BTB lt rt) = + findShortest (BTB lt rt) = let l = findShortest lt r = findShortest rt in case (l,r) of @@ -274,7 +313,7 @@ ([x], _) -> [x] -- single elem is optimum (_, [x]) -> [x] (xs, ys) -> if lazyLengthCmp xs ys - then xs else ys + then xs else ys -- lazy variant of @\xs ys -> length xs <= length ys@ lazyLengthCmp [] _ = True lazyLengthCmp _ [] = False @@ -282,7 +321,7 @@ -- | A map of dependencies. Newtyped since the default monoid instance is not -- appropriate. The monoid instance uses 'IntersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map String VersionRange } +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } #if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) deriving (Show, Read) #else @@ -314,37 +353,49 @@ instance Monoid DependencyMap where mempty = DependencyMap M.empty - (DependencyMap a) `mappend` (DependencyMap b) = + (DependencyMap a) `mappend` (DependencyMap b) = DependencyMap (M.unionWith IntersectVersionRanges a b) toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = +toDepMap ds = DependencyMap $ fromListWith IntersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] fromDepMap :: DependencyMap -> [Dependency] fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] simplifyCondTree :: (Monoid a, Monoid d) => - (v -> Either v Bool) - -> CondTree v d a + (v -> Either v Bool) + -> CondTree v d a -> (d, a) simplifyCondTree env (CondNode a d ifs) = foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs where - simplifyIf (cnd, t, me) = + simplifyIf (cnd, t, me) = case simplifyCondition cnd env of (Lit True, _) -> Just $ simplifyCondTree env t (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> error $ "Environment not defined for all free vars" + _ -> error $ "Environment not defined for all free vars" -- | Flatten a CondTree. This will resolve the CondTree by taking all -- possible paths into account. Note that since branches represent exclusive -- choices this may not result in a \"sane\" result. ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) - where f (_, t, me) = ignoreConditions t + where f (_, t, me) = ignoreConditions t : maybeToList (fmap ignoreConditions me) +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | Flag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + ------------------------------------------------------------------------------ -- Convert GenericPackageDescription to PackageDescription -- @@ -379,7 +430,7 @@ -- explicitly specified flags.) In case of failure it will return a /minimum/ -- number of dependencies that could not be satisfied. On success, it will -- return the package description and the full flag assignment chosen. --- +-- finalizePackageDescription :: Package pkg => FlagAssignment -- ^ Explicitly specified flag assignments @@ -392,8 +443,8 @@ -> GenericPackageDescription -> Either [Dependency] (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. finalizePackageDescription userflags mpkgs os arch impl constraints (GenericPackageDescription pkg flags mlib0 exes0) = case resolveFlags of @@ -427,8 +478,12 @@ ds, fs) Left missing -> Left missing - flagChoices = map (\(MkFlag n _ d) -> (n, d2c n d)) flags - d2c n b = maybe [b, not b] (\x -> [x]) $ lookup n userflags + flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookup n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices check ds = if all satisfyDep ds then DepOk diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Parse.hs @@ -0,0 +1,879 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Parse +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. +-- Some of the complexity in this module is due to the fact that we have to be +-- backwards compatible with old @.cabal@ files, so there's code to translate +-- into the newer structure. + +{- 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.PackageDescription.Parse ( + -- * Package descriptions + readPackageDescription, + writePackageDescription, + parsePackageDescription, + showPackageDescription, + + -- ** Parsing + ParseResult(..), + FieldDescr(..), + LineNo, + + -- ** Supplementary build information + readHookedBuildInfo, + parseHookedBuildInfo, + writeHookedBuildInfo, + showHookedBuildInfo, + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe, isJust) +import Data.List (nub, unfoldr, partition, (\\)) +import Control.Monad (liftM, foldM, when, unless) +import System.Directory (doesFileExist) + +import Distribution.Text + ( Text(disp, parse), display, simpleParse ) +import Text.PrettyPrint.HughesPJ + +import Distribution.ParseUtils hiding (parseFields) +import Distribution.PackageDescription +import Distribution.Package + ( PackageName(..), PackageIdentifier(..), Dependency(..) + , packageName, packageVersion ) +import Distribution.Version + ( VersionRange(AnyVersion), isAnyVersion, withinRange ) +import Distribution.Verbosity (Verbosity) +import Distribution.Compiler (CompilerFlavor(..)) +import Distribution.PackageDescription.Configuration (parseCondition, freeVars) +import Distribution.Simple.Utils + ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion + , withFileContents, withUTF8FileContents + , writeFileAtomic, writeUTF8File ) + + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +pkgDescrFieldDescrs :: [FieldDescr PackageDescription] +pkgDescrFieldDescrs = + [ simpleField "name" + disp parse + packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) + , simpleField "version" + disp parse + packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) + , simpleField "cabal-version" + disp parse + descCabalVersion (\v pkg -> pkg{descCabalVersion=v}) + , simpleField "build-type" + (maybe empty disp) (fmap Just parse) + buildType (\t pkg -> pkg{buildType=t}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "license-file" + showFilePath parseFilePathQ + licenseFile (\l pkg -> pkg{licenseFile=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , commaListField "build-depends" + disp parse + buildDepends (\xs pkg -> pkg{buildDepends=xs}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "bug-reports" + showFreeText parseFreeText + bugReports (\val pkg -> pkg{bugReports=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + , listField "tested-with" + showTestedWith parseTestedWithQ + testedWith (\val pkg -> pkg{testedWith=val}) + , listField "data-files" + showFilePath parseFilePathQ + dataFiles (\val pkg -> pkg{dataFiles=val}) + , simpleField "data-dir" + showFilePath parseFilePathQ + dataDir (\val pkg -> pkg{dataDir=val}) + , listField "extra-source-files" + showFilePath parseFilePathQ + extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) + , listField "extra-tmp-files" + showFilePath parseFilePathQ + extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) + ] + +-- | Store any fields beginning with "x-" in the customFields field of +-- a PackageDescription. All other fields will generate a warning. +storeXFieldsPD :: UnrecFieldParser PackageDescription +storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = (f,val):(customFieldsPD pkg) } +storeXFieldsPD _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Library type + +libFieldDescrs :: [FieldDescr Library] +libFieldDescrs = + [ listField "exposed-modules" disp parseModuleNameQ + exposedModules (\mods lib -> lib{exposedModules=mods}) + + , boolField "exposed" + libExposed (\val lib -> lib{libExposed=val}) + ] ++ map biToLib binfoFieldDescrs + where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) + +storeXFieldsLib :: UnrecFieldParser Library +storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = + Just $ l {libBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi) }} +storeXFieldsLib _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Executable type + + +executableFieldDescrs :: [FieldDescr Executable] +executableFieldDescrs = + [ -- note ordering: configuration must come first, for + -- showPackageDescription. + simpleField "executable" + showToken parseTokenQ + exeName (\xs exe -> exe{exeName=xs}) + , simpleField "main-is" + showFilePath parseFilePathQ + modulePath (\xs exe -> exe{modulePath=xs}) + ] + ++ map biToExe binfoFieldDescrs + where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) + +storeXFieldsExe :: UnrecFieldParser Executable +storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = + Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsExe _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + + +binfoFieldDescrs :: [FieldDescr BuildInfo] +binfoFieldDescrs = + [ boolField "buildable" + buildable (\val binfo -> binfo{buildable=val}) + , commaListField "build-tools" + disp parseBuildTool + buildTools (\xs binfo -> binfo{buildTools=xs}) + , spaceListField "cpp-options" + showToken parseTokenQ' + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "cc-options" + showToken parseTokenQ' + ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "ld-options" + showToken parseTokenQ' + ldOptions (\val binfo -> binfo{ldOptions=val}) + , commaListField "pkgconfig-depends" + disp parsePkgconfigDependency + pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\val binfo -> binfo{frameworks=val}) + , listField "c-sources" + showFilePath parseFilePathQ + cSources (\paths binfo -> binfo{cSources=paths}) + , listField "extensions" + disp parseExtensionQ + extensions (\exts binfo -> binfo{extensions=exts}) + , listField "extra-libraries" + showToken parseTokenQ + extraLibs (\xs binfo -> binfo{extraLibs=xs}) + , listField "extra-lib-dirs" + showFilePath parseFilePathQ + extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\paths binfo -> binfo{includes=paths}) + , listField "install-includes" + showFilePath parseFilePathQ + installIncludes (\paths binfo -> binfo{installIncludes=paths}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\paths binfo -> binfo{includeDirs=paths}) + , listField "hs-source-dirs" + showFilePath parseFilePathQ + hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) + , listField "other-modules" + disp parseModuleNameQ + otherModules (\val binfo -> binfo{otherModules=val}) + , listField "ghc-prof-options" + text parseTokenQ + ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) + , listField "ghc-shared-options" + text parseTokenQ + ghcProfOptions (\val binfo -> binfo{ghcSharedOptions=val}) + , optsField "ghc-options" GHC + options (\path binfo -> binfo{options=path}) + , optsField "hugs-options" Hugs + options (\path binfo -> binfo{options=path}) + , optsField "nhc98-options" NHC + options (\path binfo -> binfo{options=path}) + , optsField "jhc-options" JHC + options (\path binfo -> binfo{options=path}) + ] + +storeXFieldsBI :: UnrecFieldParser BuildInfo +storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } +storeXFieldsBI _ _ = Nothing + +------------------------------------------------------------------------------ + +flagFieldDescrs :: [FieldDescr Flag] +flagFieldDescrs = + [ simpleField "description" + showFreeText parseFreeText + flagDescription (\val fl -> fl{ flagDescription = val }) + , boolField "default" + flagDefault (\val fl -> fl{ flagDefault = val }) + , boolField "manual" + flagManual (\val fl -> fl{ flagManual = val }) + ] + +------------------------------------------------------------------------------ + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + repoType (\val repo -> repo { repoType = val }) + , simpleField "location" + (maybe empty showFreeText) (fmap Just parseFreeText) + repoLocation (\val repo -> repo { repoLocation = val }) + , simpleField "module" + (maybe empty showToken) (fmap Just parseTokenQ) + repoModule (\val repo -> repo { repoModule = val }) + , simpleField "branch" + (maybe empty showToken) (fmap Just parseTokenQ) + repoBranch (\val repo -> repo { repoBranch = val }) + , simpleField "tag" + (maybe empty showToken) (fmap Just parseTokenQ) + repoTag (\val repo -> repo { repoTag = val }) + , simpleField "subdir" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + repoSubdir (\val repo -> repo { repoSubdir = val }) + ] + +-- --------------------------------------------------------------- +-- Parsing + +-- | Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) + -> (String -> ParseResult a) + -> Verbosity + -> FilePath -> IO a +readAndParseFile withFileContents' parser verbosity fpath = do + exists <- doesFileExist fpath + when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + withFileContents' fpath $ \str -> case parser str of + ParseFailed e -> do + let (line, message) = locatedErrorMsg e + dieWithLocation fpath line message + ParseOk warnings x -> do + mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings + return x + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = + readAndParseFile withFileContents parseHookedBuildInfo + +-- |Parse the given package file. +readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readPackageDescription = + readAndParseFile withUTF8FileContents parsePackageDescription + +stanzas :: [Field] -> [[Field]] +stanzas [] = [] +stanzas (f:fields) = (f:this) : stanzas rest + where + (this, rest) = break isStanzaHeader fields + +isStanzaHeader :: Field -> Bool +isStanzaHeader (F _ f _) = f == "executable" +isStanzaHeader _ = False + +------------------------------------------------------------------------------ + + +mapSimpleFields :: (Field -> ParseResult Field) -> [Field] + -> ParseResult [Field] +mapSimpleFields f fs = mapM walk fs + where + walk fld@(F _ _ _) = f fld + walk (IfBlock l c fs1 fs2) = do + fs1' <- mapM walk fs1 + fs2' <- mapM walk fs2 + return (IfBlock l c fs1' fs2') + walk (Section ln n l fs1) = do + fs1' <- mapM walk fs1 + return (Section ln n l fs1') + +-- prop_isMapM fs = mapSimpleFields return fs == return fs + + +-- names of fields that represents dependencies, thus consrca +constraintFieldNames :: [String] +constraintFieldNames = ["build-depends"] + +-- Possible refactoring would be to have modifiers be explicit about what +-- they add and define an accessor that specifies what the dependencies +-- are. This way we would completely reuse the parsing knowledge from the +-- field descriptor. +parseConstraint :: Field -> ParseResult [Dependency] +parseConstraint (F l n v) + | n == "build-depends" = runP l n (parseCommaList parse) v +parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" + +{- +headerFieldNames :: [String] +headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) + . map fieldName $ pkgDescrFieldDescrs +-} + +libFieldNames :: [String] +libFieldNames = map fieldName libFieldDescrs + ++ buildInfoNames ++ constraintFieldNames + +-- exeFieldNames :: [String] +-- exeFieldNames = map fieldName executableFieldDescrs +-- ++ buildInfoNames + +buildInfoNames :: [String] +buildInfoNames = map fieldName binfoFieldDescrs + ++ map fst deprecatedFieldsBuildInfo + +-- A minimal implementation of the StateT monad transformer to avoid depending +-- on the 'mtl' package. +newtype StT s m a = StT { runStT :: s -> m (a,s) } + +instance Monad m => Monad (StT s m) where + return a = StT (\s -> return (a,s)) + StT f >>= g = StT $ \s -> do + (a,s') <- f s + runStT (g a) s' + +get :: Monad m => StT s m s +get = StT $ \s -> return (s, s) + +modify :: Monad m => (s -> s) -> StT s m () +modify f = StT $ \s -> return ((),f s) + +lift :: Monad m => m a -> StT s m a +lift m = StT $ \s -> m >>= \a -> return (a,s) + +evalStT :: Monad m => StT s m a -> s -> m a +evalStT st s = runStT st s >>= return . fst + +-- Our monad for parsing a list/tree of fields. +-- +-- The state represents the remaining fields to be processed. +type PM a = StT [Field] ParseResult a + + + +-- return look-ahead field or nothing if we're at the end of the file +peekField :: PM (Maybe Field) +peekField = get >>= return . listToMaybe + +-- Unconditionally discard the first field in our state. Will error when it +-- reaches end of file. (Yes, that's evil.) +skipField :: PM () +skipField = modify tail + +-- | Parses the given file into a 'GenericPackageDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription file = do + + -- This function is quite complex because it needs to be able to parse + -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains + -- a lot of parser-related noise since we do not want to depend on Parsec. + -- + -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 + -- style. See 'sectionizeFields' below for details about the conversion. + + fields0 <- readFields file `catchParseError` \err -> + let tabs = findIndentTabs file in + case err of + -- In case of a TabsError report them all at once. + TabsError tabLineNo -> reportTabsError + -- but only report the ones including and following + -- the one that caused the actual error + [ t | t@(lineNo',_) <- tabs + , lineNo' >= tabLineNo ] + _ -> parseFail err + + let cabalVersionNeeded = + head $ [ versionRange + | Just versionRange <- [ simpleParse v + | F _ "cabal-version" v <- fields0 ] ] + ++ [AnyVersion] + + handleFutureVersionParseFailure cabalVersionNeeded $ do + + let sf = sectionizeFields fields0 -- ensure 1.2 format + + -- figure out and warn about deprecated stuff (warnings are collected + -- inside our parsing monad) + fields <- mapSimpleFields deprecField sf + + -- Our parsing monad takes the not-yet-parsed fields as its state. + -- After each successful parse we remove the field from the state + -- ('skipField') and move on to the next one. + -- + -- Things are complicated a bit, because fields take a tree-like + -- structure -- they can be sections or "if"/"else" conditionals. + + flip evalStT fields $ do + + -- The header consists of all simple fields up to the first section + -- (flag, library, executable). + header_fields <- getHeader [] + + -- Parses just the header fields and stores them in a + -- 'PackageDescription'. Note that our final result is a + -- 'GenericPackageDescription'; for pragmatic reasons we just store + -- the partially filled-out 'PackageDescription' inside the + -- 'GenericPackageDescription'. + pkg <- lift $ parseFields pkgDescrFieldDescrs + storeXFieldsPD + emptyPackageDescription + header_fields + + -- 'getBody' assumes that the remaining fields only consist of + -- flags, lib and exe sections. + (repos, flags, mlib, exes) <- getBody + warnIfRest -- warn if getBody did not parse up to the last field. + when (not (oldSyntax fields0)) $ -- warn if we use new syntax + maybeWarnCabalVersion pkg -- without Cabal >= 1.2 + checkForUndefinedFlags flags mlib exes + return $ GenericPackageDescription + pkg { sourceRepos = repos } + flags mlib exes + + where + oldSyntax flds = all isSimpleField flds + reportTabsError tabs = + syntaxError (fst (head tabs)) $ + "Do not use tabs for indentation (use spaces instead)\n" + ++ " Tabs were used at (line,column): " ++ show tabs + maybeWarnCabalVersion pkg = + when (packageName pkg /= PackageName "Cabal" -- supress warning for Cabal + && isAnyVersion (descCabalVersion pkg)) $ + lift $ warning $ + "A package using section syntax should require\n" + ++ "\"Cabal-Version: >= 1.2\" or equivalent." + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = + (unless versionOk (warning message) >> parseBody) + `catchParseError` \parseError -> case parseError of + TabsError _ -> parseFail parseError + _ | versionOk -> parseFail parseError + | otherwise -> fail message + where versionOk = cabalVersion `withinRange` cabalVersionNeeded + message = "This package requires Cabal version: " + ++ display cabalVersionNeeded + + -- "Sectionize" an old-style Cabal file. A sectionized file has: + -- + -- * all global fields at the beginning, followed by + -- + -- * all flag declarations, followed by + -- + -- * an optional library section, and an arbitrary number of executable + -- sections (in any order). + -- + -- The current implementatition just gathers all library-specific fields + -- in a library section and wraps all executable stanzas in an executable + -- section. + sectionizeFields :: [Field] -> [Field] + sectionizeFields fs + | oldSyntax fs = + let + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . fName) fs + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 + + (deps, libfs) = partition ((== "build-depends") . fName) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe (F l e n : r) + | e == "executable" = + let (efs, r') = break ((=="executable") . fName) r + in Just (Section l "executable" n (deps ++ efs), r') + toExe _ = bug "unexpeced input to 'toExe'" + in + hdr ++ + (if null libfs then [] + else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) + ++ exes + | otherwise = fs + + isSimpleField (F _ _ _) = True + isSimpleField _ = False + + -- warn if there's something at the end of the file + warnIfRest :: PM () + warnIfRest = do + s <- get + case s of + [] -> return () + _ -> lift $ warning "Ignoring trailing declarations." -- add line no. + + -- all simple fields at the beginning of the file are (considered) header + -- fields + getHeader :: [Field] -> PM [Field] + getHeader acc = peekField >>= \mf -> case mf of + Just f@(F _ _ _) -> skipField >> getHeader (f:acc) + _ -> return (reverse acc) + + -- + -- body ::= { repo | flag | library | executable }+ -- at most one lib + -- + -- The body consists of an optional sequence of declarations of flags and + -- an arbitrary number of executables and at most one library. + getBody :: PM ([SourceRepo], [Flag] + ,Maybe (CondTree ConfVar [Dependency] Library) + ,[(String, CondTree ConfVar [Dependency] Executable)]) + getBody = peekField >>= \mf -> case mf of + Just (Section line_no sec_type sec_label sec_fields) + | sec_type == "executable" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'executable' needs one argument (the executable's name)" + exename <- lift $ runP line_no "executable" parseTokenQ sec_label + flds <- collectFields parseExeFields sec_fields + skipField + (repos, flags, lib, exes) <- getBody + return (repos, flags, lib, exes ++ [(exename, flds)]) + + | sec_type == "library" -> do + when (not (null sec_label)) $ lift $ + syntaxError line_no "'library' expects no argument" + flds <- collectFields parseLibFields sec_fields + skipField + (repos, flags, lib, exes) <- getBody + when (isJust lib) $ lift $ syntaxError line_no + "There can only be one library section in a package description." + return (repos, flags, Just flds, exes) + + | sec_type == "flag" -> do + when (null sec_label) $ lift $ + syntaxError line_no "'flag' needs one argument (the flag's name)" + flag <- lift $ parseFields + flagFieldDescrs + warnUnrec + (MkFlag (FlagName (lowercase sec_label)) "" True False) + sec_fields + skipField + (repos, flags, lib, exes) <- getBody + return (repos, flag:flags, lib, exes) + + | sec_type == "source-repository" -> do + when (null sec_label) $ lift $ syntaxError line_no $ + "'source-repository' needs one argument, " + ++ "the repo kind which is usually 'head' or 'this'" + kind <- case simpleParse sec_label of + Just kind -> return kind + Nothing -> lift $ syntaxError line_no $ + "could not parse repo kind: " ++ sec_label + repo <- lift $ parseFields + sourceRepoFieldDescrs + warnUnrec + (SourceRepo { + repoKind = kind, + repoType = Nothing, + repoLocation = Nothing, + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing + }) + sec_fields + skipField + (repos, flags, lib, exes) <- getBody + return (repo:repos, flags, lib, exes) + + | otherwise -> do + lift $ warning $ "Ignoring unknown section type: " ++ sec_type + skipField + getBody + Just f -> do + lift $ syntaxError (lineNo f) $ + "Construct not supported at this position: " ++ show f + skipField + getBody + Nothing -> return ([], [], Nothing, []) + + -- Extracts all fields in a block and returns a 'CondTree'. + -- + -- We have to recurse down into conditionals and we treat fields that + -- describe dependencies specially. + collectFields :: ([Field] -> PM a) -> [Field] + -> PM (CondTree ConfVar [Dependency] a) + collectFields parser allflds = do + + let simplFlds = [ F l n v | F l n v <- allflds ] + condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] + + let (depFlds, dataFlds) = partition isConstraint simplFlds + + a <- parser dataFlds + deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds + + ifs <- mapM processIfs condFlds + + return (CondNode a deps ifs) + where + isConstraint (F _ n _) = n `elem` constraintFieldNames + isConstraint _ = False + + processIfs (IfBlock l c t e) = do + cnd <- lift $ runP l "if" parseCondition c + t' <- collectFields parser t + e' <- case e of + [] -> return Nothing + es -> do fs <- collectFields parser es + return (Just fs) + return (cnd, t', e') + processIfs _ = bug "processIfs called with wrong field type" + + parseLibFields :: [Field] -> PM Library + parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + + parseExeFields :: [Field] -> PM Executable + parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable + + checkForUndefinedFlags :: + [Flag] -> + Maybe (CondTree ConfVar [Dependency] Library) -> + [(String, CondTree ConfVar [Dependency] Executable)] -> + PM () + checkForUndefinedFlags flags mlib exes = do + let definedFlags = map flagName flags + maybe (return ()) (checkCondTreeFlags definedFlags) mlib + mapM_ (checkCondTreeFlags definedFlags . snd) exes + + checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () + checkCondTreeFlags definedFlags ct = do + let fv = nub $ freeVars ct + when (not . all (`elem` definedFlags) $ fv) $ + fail $ "These flags are used without having been defined: " + ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] + + +-- | Parse a list of fields, given a list of field descriptions, +-- a structure to accumulate the parsed fields, and a function +-- that can decide what to do with fields which don't match any +-- of the field descriptions. +parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to + -- parse + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> a -- ^ accumulator + -> [Field] -- ^ fields to be parsed + -> ParseResult a +parseFields descrs unrec ini fields = + do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields + when (not (null unknowns)) $ do + warning $ render $ + text "Unknown fields:" <+> + commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") + (reverse unknowns)) + $+$ + text "Fields allowed in this section:" $$ + nest 4 (commaSep $ map fieldName descrs) + return a + where + commaSep = fsep . punctuate comma . map text + +parseField :: [FieldDescr a] -- ^ list of parseable fields + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> (a,[(Int,String)]) -- ^ accumulated result and warnings + -> Field -- ^ the field to be parsed + -> ParseResult (a, [(Int,String)]) +parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) + | name == f = parser line val a >>= \a' -> return (a',us) + | otherwise = parseField fields unrec (a,us) (F line f val) +parseField [] unrec (a,us) (F l f val) = return $ + case unrec (f,val) a of -- no fields matched, see if the 'unrec' + Just a' -> (a',us) -- function wants to do anything with it + Nothing -> (a, ((l,f):us)) +parseField _ _ _ _ = bug "'parseField' called on a non-field" + +deprecatedFields :: [(String,String)] +deprecatedFields = + deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo + +deprecatedFieldsPkgDescr :: [(String,String)] +deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] + +deprecatedFieldsBuildInfo :: [(String,String)] +deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] + +-- Handle deprecated fields +deprecField :: Field -> ParseResult Field +deprecField (F line fld val) = do + fld' <- case lookup fld deprecatedFields of + Nothing -> return fld + Just newName -> do + warning $ "The field \"" ++ fld + ++ "\" is deprecated, please use \"" ++ newName ++ "\"" + return newName + return (F line fld' val) +deprecField _ = bug "'deprecField' called on a non-field" + + +parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo +parseHookedBuildInfo inp = do + fields <- readFields inp + let ss@(mLibFields:exes) = stanzas fields + mLib <- parseLib mLibFields + biExes <- mapM parseExe (maybe ss (const exes) mLib) + return (mLib, biExes) + where + parseLib :: [Field] -> ParseResult (Maybe BuildInfo) + parseLib (bi@((F _ inFieldName _):_)) + | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) + parseLib _ = return Nothing + + parseExe :: [Field] -> ParseResult (String, BuildInfo) + parseExe ((F line inFieldName mName):bi) + | lowercase inFieldName == "executable" + = do bis <- parseBI bi + return (mName, bis) + | otherwise = syntaxError line "expecting 'executable' at top of stanza" + parseExe (_:_) = bug "`parseExe' called on a non-field" + parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" + + parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st + +-- --------------------------------------------------------------------------- +-- Pretty printing + +writePackageDescription :: FilePath -> PackageDescription -> IO () +writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) + +showPackageDescription :: PackageDescription -> String +showPackageDescription pkg = render $ + ppPackage pkg + $$ ppCustomFields (customFieldsPD pkg) + $$ (case library pkg of + Nothing -> empty + Just lib -> ppLibrary lib) + $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] + where + ppPackage = ppFields pkgDescrFieldDescrs + ppLibrary = ppFields libFieldDescrs + ppExecutable = ppFields executableFieldDescrs + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat (map ppCustomField flds) + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo + +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ + (case mb_lib_bi of + Nothing -> empty + Just bi -> ppBuildInfo bi) + $$ vcat [ space + $$ text "executable:" <+> text name + $$ ppBuildInfo bi + | (name, bi) <- ex_bis ] + where + ppBuildInfo bi = ppFields binfoFieldDescrs bi + $$ ppCustomFields (customFieldsBI bi) + +-- replace all tabs used as indentation with whitespace, also return where +-- tabs were found +findIndentTabs :: String -> [(Int,Int)] +findIndentTabs = concatMap checkLine + . zip [1..] + . lines + where + checkLine (lineno, l) = + let (indent, _content) = span isSpace l + tabCols = map fst . filter ((== '\t') . snd) . zip [0..] + addLineNo = map (\col -> (lineno,col)) + in addLineNo (tabCols indent) + +--test_findIndentTabs = findIndentTabs $ unlines $ +-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -2,13 +2,18 @@ -- | -- Module : Distribution.ParseUtils -- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Utilities for parsing PackageDescription and InstalledPackageInfo. - +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. {- All rights reserved. @@ -45,17 +50,18 @@ -- #hide module Distribution.ParseUtils ( LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, - Field(..), fName, lineNo, - FieldDescr(..), ppField, ppFields, readFields, - parseFilePathQ, parseTokenQ, - parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, + runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, + Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, + showFields, showSingleNamedField, parseFields, + parseFilePathQ, parseTokenQ, parseTokenQ', + parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, parseOptVersion, parsePackageNameQ, parseVersionRangeQ, - parseTestedWithQ, parseLicenseQ, parseExtensionQ, - parseSepList, parseCommaList, parseOptCommaList, - showFilePath, showToken, showTestedWith, showFreeText, - field, simpleField, listField, commaListField, optsField, liftField, - boolField, parseQuoted, + parseTestedWithQ, parseLicenseQ, parseExtensionQ, + parseSepList, parseCommaList, parseOptCommaList, + showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, + field, simpleField, listField, spaceListField, commaListField, + optsField, liftField, boolField, parseQuoted, UnrecFieldParser, warnUnrec, ignoreUnrec, ) where @@ -63,7 +69,8 @@ import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) import Distribution.License import Distribution.Version -import Distribution.Package ( parsePackageName, Dependency(..) ) +import Distribution.Package ( PackageName(..), Dependency(..) ) +import Distribution.ModuleName (ModuleName) import Distribution.Compat.ReadP as ReadP hiding (get) import Distribution.ReadE import Distribution.Text @@ -72,9 +79,11 @@ import Language.Haskell.Extension (Extension) import Text.PrettyPrint.HughesPJ hiding (braces) -import Data.Char (isSpace, isUpper, toLower, isAlphaNum, isDigit) -import Data.Maybe (fromMaybe) +import Data.Char (isSpace, toLower, isAlphaNum, isDigit) +import Data.Maybe (fromMaybe) import Data.Tree as Tree (Tree(..), flatten) +import qualified Data.Map as Map +import Control.Monad (foldM) import System.FilePath (normalise) -- ----------------------------------------------------------------------------- @@ -102,12 +111,12 @@ deriving Show instance Monad ParseResult where - return x = ParseOk [] x - ParseFailed err >>= _ = ParseFailed err - ParseOk ws x >>= f = case f x of - ParseFailed err -> ParseFailed err - ParseOk ws' x' -> ParseOk (ws'++ws) x' - fail s = ParseFailed (FromString s Nothing) + return x = ParseOk [] x + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + fail s = ParseFailed (FromString s Nothing) catchParseError :: ParseResult a -> (PError -> ParseResult a) -> ParseResult a @@ -159,8 +168,8 @@ -- | Field descriptor. The parameter @a@ parameterizes over where the field's -- value is stored in. -data FieldDescr a - = FieldDescr +data FieldDescr a + = FieldDescr { fieldName :: String , fieldGet :: a -> Doc , fieldSet :: LineNo -> String -> a -> ParseResult a @@ -170,7 +179,7 @@ } field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a -field name showF readF = +field name showF readF = FieldDescr name showF (\line val _st -> runP line name readF val) -- Lift a field descriptor storing into an 'a' to a field descriptor storing @@ -178,9 +187,9 @@ liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b liftField get set (FieldDescr name showF parseF) = FieldDescr name (\b -> showF (get b)) - (\line str b -> do - a <- parseF line str (get b) - return (set a b)) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) -- Parser combinator for simple fields. Takes a field name, a pretty printer, -- a parser function, an accessor, and a setter, returns a FieldDescr over the @@ -191,30 +200,38 @@ = liftField get set $ field name showF readF commaListField :: String -> (a -> Doc) -> (ReadP [a] a) - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListField name showF readF get set = + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField name showF readF get set = liftField get set' $ field name (fsep . punctuate comma . map showF) (parseCommaList readF) where set' xs b = set (get b ++ xs) b +spaceListField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + listField :: String -> (a -> Doc) -> (ReadP [a] a) - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listField name showF readF get set = + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField name showF readF get set = liftField get set' $ field name (fsep . map showF) (parseOptCommaList readF) where set' xs b = set (get b ++ xs) b optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b -optsField name flavor get set = - liftField (fromMaybe [] . lookup flavor . get) - (\opts b -> set (update flavor opts (get b)) b) $ - field name (hsep . map text) - (sepBy parseTokenQ' (munch1 isSpace)) +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (update flavor opts (get b)) b) $ + field name (hsep . map text) + (sepBy parseTokenQ' (munch1 isSpace)) where update f opts [] = [(f,opts)] - update f opts ((f',opts'):rest) + update f opts ((f',opts'):rest) | f == f' = (f, opts' ++ opts) : rest | otherwise = (f',opts') : update f opts rest @@ -236,15 +253,37 @@ caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." -ppFields :: a -> [FieldDescr a] -> Doc -ppFields _ [] = empty -ppFields pkg' ((FieldDescr name getter _):flds) = - ppField name (getter pkg') $$ ppFields pkg' flds +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields] ppField :: String -> Doc -> Doc ppField name fielddoc = text name <> colon <+> fielddoc +showFields :: [FieldDescr a] -> a -> String +showFields fields = render . ppFields fields +showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (render . ppField f . get) + +parseFields :: [FieldDescr a] -> a -> String -> ParseResult a +parseFields fields initial = \str -> + readFields str >>= foldM setField initial + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning ("Unrecognized field " ++ name ++ " on line " ++ show line) + return accum + setField accum f = do + warning ("Unrecognized stanza on line " ++ show (lineNo f)) + return accum + -- | The type of a function which, given a name-value pair of an -- unrecognized field, and the current structure being built, -- decides whether to incorporate the unrecognized field @@ -265,14 +304,14 @@ ------------------------------------------------------------------------------ --- The data type for our three syntactic categories -data Field +-- The data type for our three syntactic categories +data Field = F LineNo String String -- ^ A regular @: @ field | Section LineNo String String [Field] -- ^ A section with a name and possible parameter. The syntactic -- structure is: - -- + -- -- @ -- { -- * @@ -323,13 +362,13 @@ -- | We parse generically based on indent level and braces '{' '}'. To do that -- we split into lines and then '{' '}' tokens and other spans within a line. -data Token = +data Token = -- | The 'Line' token is for bits that /start/ a line, eg: -- -- > "\n blah blah { blah" -- -- tokenises to: - -- + -- -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] -- -- so lines are the only ones that can have nested layout, since they @@ -351,11 +390,11 @@ -- -- but that's not so common, people would normally use layout or -- brackets not both in a single @if else@ construct. - -- + -- -- > if ... { foo : bar } -- > else -- > other - -- + -- -- this is ok Line LineNo Indent HasTabs String | Span LineNo String -- ^ span in a line, following brackets @@ -375,7 +414,7 @@ ("", '{' : s') -> OpenBracket n : split n s' (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') ("", '}' : s') -> CloseBracket n : split n s' - (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') (w , _) -> mkspan n w [] mkspan n s ss | null s' = ss @@ -449,7 +488,7 @@ (sub, ss') <- braces n' [] ss braces m (Node (n,t,l) sub:a) ss' -braces m a (Span n l:OpenBracket n':ss) = do +braces m a (Span n l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss braces m (Node (n,False,l) sub:a) ss' @@ -477,7 +516,7 @@ if tabs && d >= 1 then tabsError n else return $ F n (map toLower name) - (fieldValue rest' followingLines) + (fieldValue rest' followingLines) rest' -> do ts' <- mapM (mkField (d+1)) ts return (Section n (map toLower name) rest' ts') where fieldValue firstLine followingLines = @@ -512,21 +551,17 @@ ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' fs''' <- ifelse fs return (Section n s a fs'' : fs''') -ifelse (f:fs) = do fs' <- ifelse fs +ifelse (f:fs) = do fs' <- ifelse fs return (f : fs') ------------------------------------------------------------------------------ -- |parse a module name -parseModuleNameQ :: ReadP r String -parseModuleNameQ = parseQuoted modu <++ modu - where modu = do - c <- satisfy isUpper - cs <- munch (\x -> isAlphaNum x || x `elem` "_'.") - return (c:cs) +parseModuleNameQ :: ReadP r ModuleName +parseModuleNameQ = parseQuoted parse <++ parse parseFilePathQ :: ReadP r FilePath -parseFilePathQ = parseTokenQ +parseFilePathQ = parseTokenQ -- removed until normalise is no longer broken, was: -- liftM normalise parseTokenQ @@ -537,18 +572,18 @@ skipSpaces return $ Dependency name ver -parseBuildToolNameQ :: ReadP r String +parseBuildToolNameQ :: ReadP r PackageName parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName -- like parsePackageName but accepts symbols in components -parseBuildToolName :: ReadP r String +parseBuildToolName :: ReadP r PackageName parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') - return (intercalate "-" ns) + return (PackageName (intercalate "-" ns)) where component = do cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') if all isDigit cs then pfail else return cs --- pkg-config allows versions and other letters in package names, +-- pkg-config allows versions and other letters in package names, -- eg "gtk+-2.0" is a valid pkg-config package _name_. -- It then has a package version number like 2.10.13 parsePkgconfigDependency :: ReadP r Dependency @@ -556,10 +591,10 @@ skipSpaces ver <- parseVersionRangeQ <++ return AnyVersion skipSpaces - return $ Dependency name ver + return $ Dependency (PackageName name) ver -parsePackageNameQ :: ReadP r String -parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName +parsePackageNameQ :: ReadP r PackageName +parsePackageNameQ = parseQuoted parse <++ parse parseVersionRangeQ :: ReadP r VersionRange parseVersionRangeQ = parseQuoted parse <++ parse @@ -567,15 +602,15 @@ parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver where ver = parse <++ return noVersion - noVersion = Version{ versionBranch=[], versionTags=[] } + noVersion = Version{ versionBranch=[], versionTags=[] } parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw where tw = do compiler <- parseCompilerFlavorCompat - skipSpaces - version <- parse <++ return AnyVersion - skipSpaces - return (compiler,version) + skipSpaces + version <- parse <++ return AnyVersion + skipSpaces + return (compiler,version) parseLicenseQ :: ReadP r License parseLicenseQ = parseQuoted parse <++ parse @@ -598,11 +633,15 @@ parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) parseSepList :: ReadP r b - -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] parseSepList sepr p = sepBy p separator where separator = skipSpaces >> sepr >> skipSpaces +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + parseCommaList :: ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] parseCommaList = parseSepList (ReadP.char ',') @@ -613,6 +652,9 @@ parseQuoted :: ReadP r a -> ReadP r a parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p + +parseFreeText :: ReadP.ReadP s String +parseFreeText = ReadP.munch (const True) -- -------------------------------------------- -- ** Pretty printing diff --git a/Distribution/ReadE.hs b/Distribution/ReadE.hs --- a/Distribution/ReadE.hs +++ b/Distribution/ReadE.hs @@ -3,8 +3,7 @@ -- Module : Distribution.ReadE -- Copyright : Jose Iborra 2008 -- --- Maintainer : Isaac Jones --- Stability : alpha +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Simple parsing with failure @@ -76,7 +75,7 @@ readEOrFail r = either error id . runReadE r readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a -readP_to_E err r = +readP_to_E err r = ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt , all isSpace s ] of [] -> Left (err txt) diff --git a/Distribution/Setup.hs b/Distribution/Setup.hs deleted file mode 100644 --- a/Distribution/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Distribution.Setup -{-# DEPRECATED "Use module Distribution.Simple.Setup instead" #-} - (module Distribution.Simple.Setup) where - -import Distribution.Simple.Setup diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -2,19 +2,27 @@ -- | -- Module : Distribution.Simple -- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Simple build system; basically the interface for --- Distribution.Simple.\* modules. When given the parsed command-line --- args and package information, is able to perform basic commands --- like configure, build, install, register, etc. +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. -- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- -- This module isn't called \"Simple\" because it's simple. Far from -- it. It's called \"Simple\" because it does complicated things to -- simple software. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. {- All rights reserved. @@ -47,17 +55,17 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, + module Distribution.Package, + module Distribution.Version, + module Distribution.License, + module Distribution.Simple.Compiler, + module Language.Haskell.Extension, -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, + defaultMain, defaultMainNoRead, defaultMainArgs, -- * Customization UserHooks(..), Args, defaultMainWithHooks, defaultMainWithHooksArgs, - -- ** Standard sets of hooks + -- ** Standard sets of hooks simpleUserHooks, autoconfUserHooks, defaultUserHooks, emptyUserHooks, @@ -72,25 +80,26 @@ import Distribution.PackageDescription ( PackageDescription(..), GenericPackageDescription , updatePackageDescription, hasLibs - , HookedBuildInfo, emptyHookedBuildInfo - , readPackageDescription, readHookedBuildInfo ) + , HookedBuildInfo, emptyHookedBuildInfo ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, readHookedBuildInfo ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Simple.Program - ( ProgramConfiguration, defaultProgramConfiguration, addKnownProgram - , userSpecifyArgs ) + ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms + , restoreProgramConfiguration, reconfigurePrograms ) import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Build ( build, makefile ) -import Distribution.Simple.SrcDist ( sdist ) -import Distribution.Simple.Register ( register, unregister, +import Distribution.Simple.Build ( build, makefile ) +import Distribution.Simple.SrcDist ( sdist ) +import Distribution.Simple.Register ( register, unregister, writeInstalledConfig, removeRegScripts ) -import Distribution.Simple.Configure(getPersistBuildConfig, +import Distribution.Simple.Configure(getPersistBuildConfig, maybeGetPersistBuildConfig, checkPersistBuildConfig, configure, writePersistBuildConfig) @@ -171,7 +180,7 @@ printVersion = putStrLn $ "Cabal library version " ++ display cabalVersion - progs = allPrograms hooks + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration commands = [configureCommand progs `commandAddAction` configureAction hooks ,buildCommand progs `commandAddAction` buildAction hooks @@ -187,14 +196,6 @@ ,makefileCommand `commandAddAction` makefileAction hooks ] --- | Combine the programs in the given hooks with the programs built --- into cabal. -allPrograms :: UserHooks - -> ProgramConfiguration -- combine defaults w/ user programs -allPrograms h = foldl (flip addKnownProgram) - defaultProgramConfiguration - (hookedPrograms h) - -- | Combine the preprocessors in the given hooks with the -- preprocessors built into cabal. allSuffixHandlers :: UserHooks @@ -219,13 +220,13 @@ --(warns, ers) <- sanityCheckPackage pkg_descr --errorOut (configVerbosity flags') warns ers - localbuildinfo0 <- confHook hooks epkg_descr flags + localbuildinfo0 <- confHook hooks epkg_descr flags -- remember the .cabal filename if we know it let localbuildinfo = localbuildinfo0{ pkgDescrFile = mb_pd_file } writePersistBuildConfig distPref localbuildinfo - - let pkg_descr = localPkgDescr localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo postConf hooks args flags pkg_descr localbuildinfo where verbosity = fromFlag (configVerbosity flags) @@ -243,37 +244,48 @@ buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do - let distPref = fromFlag $ buildDistPref flags - lbi <- getBuildConfigIfUpToDate distPref - let progs = foldl userSpecifyArgs' - (withPrograms lbi) (buildProgramArgs flags) - where userSpecifyArgs' conf (prog, args') = - userSpecifyArgs prog args' conf - hookedAction preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags args + let distPref = fromFlag $ buildDistPref flags + verbosity = fromFlag $ buildVerbosity flags + lbi <- getBuildConfig hooks distPref + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags) + (buildProgramArgs flags) + (withPrograms lbi) + + hookedAction preBuild buildHook postBuild + (return lbi { withPrograms = progs }) + hooks flags args + makefileAction :: UserHooks -> MakefileFlags -> Args -> IO () makefileAction hooks flags args = do let distPref = fromFlag $ makefileDistPref flags hookedAction preMakefile makefileHook postMakefile - (getBuildConfigIfUpToDate distPref) + (getBuildConfig hooks distPref) hooks flags args hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args = do let distPref = fromFlag $ hscolourDistPref flags hookedAction preHscolour hscolourHook postHscolour - (getBuildConfigIfUpToDate distPref) + (getBuildConfig hooks distPref) hooks flags args - + haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () -haddockAction hooks flags args - = do let distPref = fromFlag $ haddockDistPref flags - hookedAction preHaddock haddockHook postHaddock - (getBuildConfigIfUpToDate distPref) - hooks flags args +haddockAction hooks flags args = do + let distPref = fromFlag $ haddockDistPref flags + verbosity = fromFlag $ haddockVerbosity flags + lbi <- getBuildConfig hooks distPref + progs <- reconfigurePrograms verbosity + (haddockProgramPaths flags) + (haddockProgramArgs flags) + (withPrograms lbi) + + hookedAction preHaddock haddockHook postHaddock + (return lbi { withPrograms = progs }) + hooks flags args + cleanAction :: UserHooks -> CleanFlags -> Args -> IO () cleanAction hooks flags args = do let distPref = fromFlag $ cleanDistPref flags @@ -293,14 +305,14 @@ copyAction hooks flags args = do let distPref = fromFlag $ copyDistPref flags hookedAction preCopy copyHook postCopy - (getBuildConfigIfUpToDate distPref) + (getBuildConfig hooks distPref) hooks flags args installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args = do let distPref = fromFlag $ installDistPref flags hookedAction preInst instHook postInst - (getBuildConfigIfUpToDate distPref) + (getBuildConfig hooks distPref) hooks flags args sdistAction :: UserHooks -> SDistFlags -> Args -> IO () @@ -321,7 +333,7 @@ testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do let distPref = fromFlag $ testDistPref flags - localbuildinfo <- getBuildConfigIfUpToDate distPref + localbuildinfo <- getBuildConfig hooks distPref let pkg_descr = localPkgDescr localbuildinfo runTests hooks args False pkg_descr localbuildinfo @@ -329,14 +341,14 @@ registerAction hooks flags args = do let distPref = fromFlag $ regDistPref flags hookedAction preReg regHook postReg - (getBuildConfigIfUpToDate distPref) + (getBuildConfig hooks distPref) hooks flags args unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args = do let distPref = fromFlag $ regDistPref flags hookedAction preUnreg unregHook postUnreg - (getBuildConfigIfUpToDate distPref) + (getBuildConfig hooks distPref) hooks flags args hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) @@ -357,13 +369,17 @@ cmd_hook hooks pkg_descr localbuildinfo hooks flags post_hook hooks args flags pkg_descr localbuildinfo -getBuildConfigIfUpToDate :: FilePath -> IO LocalBuildInfo -getBuildConfigIfUpToDate distPref = do - lbi <- getPersistBuildConfig distPref - case pkgDescrFile lbi of - Nothing -> return () - Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file - return lbi +getBuildConfig :: UserHooks -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks distPref = do + lbi <- getPersistBuildConfig distPref + case pkgDescrFile lbi of + Nothing -> return () + Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file + return lbi { + withPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi) + } -- -------------------------------------------------------------------------- -- Cleaning @@ -405,10 +421,10 @@ -- -------------------------------------------------------------------------- -- Default hooks --- | Hooks that correspond to a plain instantiation of the +-- | Hooks that correspond to a plain instantiation of the -- \"simple\" build system simpleUserHooks :: UserHooks -simpleUserHooks = +simpleUserHooks = emptyUserHooks { confHook = configure, buildHook = defaultBuildHook, @@ -436,17 +452,19 @@ -- FIXME: do something sensible for windows, or do nothing in postConf. +{-# DEPRECATED defaultUserHooks + "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} defaultUserHooks :: UserHooks defaultUserHooks = autoconfUserHooks { confHook = \pkg flags -> do - let verbosity = fromFlag (configVerbosity flags) - warn verbosity $ - "defaultUserHooks in Setup script is deprecated." - confHook autoconfUserHooks pkg flags, + let verbosity = fromFlag (configVerbosity flags) + warn verbosity $ + "defaultUserHooks in Setup script is deprecated." + confHook autoconfUserHooks pkg flags, postConf = oldCompatPostConf } -- This is the annoying old version that only runs configure if it exists. - -- It's here for compatability with existing Setup.hs scripts. See: + -- It's here for compatibility with existing Setup.hs scripts. See: -- http://hackage.haskell.org/trac/hackage/ticket/165 where oldCompatPostConf args flags _ _ = do let verbosity = fromFlag (configVerbosity flags) @@ -480,7 +498,7 @@ if confExists then rawSystemExit verbosity "sh" $ "configure" - : configureArgs backwardsCompatHack flags + : configureArgs backwardsCompatHack flags else die "configure script not found." backwardsCompatHack = False @@ -498,18 +516,24 @@ defaultInstallHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () defaultInstallHook pkg_descr localbuildinfo _ flags = do - install pkg_descr localbuildinfo defaultCopyFlags { - copyDest' = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ - register pkg_descr localbuildinfo defaultRegisterFlags { - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyInPlace = installInPlace flags, + copyUseWrapper = installUseWrapper flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () + -> UserHooks -> BuildFlags -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags = do let distPref = fromFlag $ buildDistPref flags build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) @@ -517,7 +541,7 @@ writeInstalledConfig distPref pkg_descr localbuildinfo False Nothing defaultMakefileHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> MakefileFlags -> IO () + -> UserHooks -> MakefileFlags -> IO () defaultMakefileHook pkg_descr localbuildinfo hooks flags = do let distPref = fromFlag $ makefileDistPref flags makefile pkg_descr localbuildinfo flags (allSuffixHandlers hooks) @@ -525,7 +549,7 @@ writeInstalledConfig distPref pkg_descr localbuildinfo False Nothing defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () + -> UserHooks -> RegisterFlags -> IO () defaultRegHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -1,14 +1,23 @@ ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build --- Copyright : Isaac Jones 2003-2005 +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 -- --- Maintainer : Isaac Jones --- Stability : alpha +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Invokes the "Distribution.Compiler"s to build the library and --- executables in this package. +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +-- +-- There's some stuff to do with generating @makefiles@ which is a well hidden +-- feature that's used to build libraries inside the GHC build system but which +-- we'd like to kill off and replace with something better (doing our own +-- dependency analysis properly). +-- {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -42,46 +51,53 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Build ( - build, makefile, initialBuildSteps + build, + makefile, + + initialBuildSteps, + writeAutogenFiles, ) where +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.Hugs as Hugs + +import qualified Distribution.Simple.Build.Macros as Build.Macros +import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule + +import Distribution.Package + ( Package(..) ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor ) import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), - Executable(..), Library(..) ) -import Distribution.Package - ( Package(..), packageName, packageVersion ) -import Distribution.Simple.Setup ( CopyDest(..), BuildFlags(..), - MakefileFlags(..), fromFlag ) -import Distribution.Simple.PreProcess ( preprocessSources, PPSuffixHandler ) + ( PackageDescription(..), BuildInfo(..) + , Executable(..), Library(..), hasLibs ) +import qualified Distribution.ModuleName as ModuleName + +import Distribution.Simple.Setup + ( BuildFlags(..), MakefileFlags(..), fromFlag ) +import Distribution.Simple.PreProcess + ( preprocessSources, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), - InstallDirs(..), absoluteInstallDirs, - prefixRelativeInstallDirs ) -import Distribution.Simple.BuildPaths ( autogenModuleName ) -import Distribution.Simple.Configure - ( localBuildInfoFile ) + ( LocalBuildInfo(compiler, buildDir) ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir, autogenModuleName, cppHeaderName ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, die, setupMessage, writeUTF8File ) -import Distribution.System - -import System.FilePath ( (), pathSeparator ) - -import Data.Maybe ( maybeToList, fromJust, isNothing ) -import Control.Monad ( unless, when ) -import System.Directory ( getModificationTime, doesFileExist ) - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.JHC as JHC -import qualified Distribution.Simple.NHC as NHC -import qualified Distribution.Simple.Hugs as Hugs + ( createDirectoryIfMissingVerbose, die, setupMessage, rewriteFile ) -import Distribution.PackageDescription (hasLibs) import Distribution.Verbosity + ( Verbosity ) import Distribution.Text ( display ) +import Data.Maybe + ( maybeToList ) +import Control.Monad + ( unless, when ) +import System.FilePath + ( (), (<.>) ) + -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. @@ -125,7 +141,7 @@ -> Verbosity -- ^The verbosity to use -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling -> IO () -initialBuildSteps distPref pkg_descr lbi verbosity suffixes = do +initialBuildSteps _distPref pkg_descr lbi verbosity suffixes = do -- check that there's something to build let buildInfos = map libBuildInfo (maybeToList (library pkg_descr)) ++ @@ -136,211 +152,22 @@ createDirectoryIfMissingVerbose verbosity True (buildDir lbi) - -- construct and write the Paths_.hs file - createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) - buildPathsModule distPref pkg_descr lbi + writeAutogenFiles verbosity pkg_descr lbi preprocessSources pkg_descr lbi False verbosity suffixes --- ------------------------------------------------------------ --- * Building Paths_.hs --- ------------------------------------------------------------ - --- The directory in which we put auto-generated modules -autogenModulesDir :: LocalBuildInfo -> String -autogenModulesDir lbi = buildDir lbi "autogen" - -buildPathsModule :: FilePath -> PackageDescription -> LocalBuildInfo -> IO () -buildPathsModule distPref pkg_descr lbi = - let pragmas - | absolute || isHugs = "" - | otherwise = - "{-# LANGUAGE ForeignFunctionInterface #-}\n" ++ - "{-# OPTIONS_GHC -fffi #-}\n"++ - "{-# OPTIONS_JHC -fffi #-}\n" - - foreign_imports - | absolute = "" - | isHugs = "import System.Environment\n" - | otherwise = - "import Foreign\n"++ - "import Foreign.C\n" - - header = - pragmas++ - "module " ++ paths_modulename ++ " (\n"++ - "\tversion,\n"++ - "\tgetBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ - "\tgetDataFileName\n"++ - "\t) where\n"++ - "\n"++ - foreign_imports++ - "import Data.Version (Version(..))\n"++ - "import System.Environment (getEnv)"++ - "\n"++ - "\nversion :: Version"++ - "\nversion = " ++ show (packageVersion pkg_descr)++ - "\n" - - body - | absolute = - "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ - "\nbindir = " ++ show flat_bindir ++ - "\nlibdir = " ++ show flat_libdir ++ - "\ndatadir = " ++ show flat_datadir ++ - "\nlibexecdir = " ++ show flat_libexecdir ++ - "\n"++ - "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ - "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ - "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ - "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir ++ "++path_sep++" ++ name)\n" - | otherwise = - "\nprefix, bindirrel :: FilePath" ++ - "\nprefix = " ++ show flat_prefix ++ - "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ - "\n\n"++ - "getBinDir :: IO FilePath\n"++ - "getBinDir = getPrefixDirRel bindirrel\n\n"++ - "getLibDir :: IO FilePath\n"++ - "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ - "getDataDir :: IO FilePath\n"++ - "getDataDir = "++ mkGetEnvOr "datadir" - (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ - "getLibexecDir :: IO FilePath\n"++ - "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_stuff++ - "\n"++ - filename_stuff - in do btime <- getModificationTime (localBuildInfoFile distPref) - exists <- doesFileExist paths_filepath - ptime <- if exists - then getModificationTime paths_filepath - else return btime - if btime >= ptime - then writeUTF8File paths_filepath (header++body) - else return () - where - InstallDirs { - prefix = flat_prefix, - bindir = flat_bindir, - libdir = flat_libdir, - datadir = flat_datadir, - libexecdir = flat_libexecdir - } = absoluteInstallDirs pkg_descr lbi NoCopyDest - InstallDirs { - bindir = flat_bindirrel, - libdir = flat_libdirrel, - datadir = flat_datadirrel, - libexecdir = flat_libexecdirrel, - progdir = flat_progdirrel - } = prefixRelativeInstallDirs pkg_descr lbi - - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir - - mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++ - " (\\_ -> "++expr++")" - where var' = packageName pkg_descr ++ "_" ++ var - - -- In several cases we cannot make relocatable installations - absolute = - hasLibs pkg_descr -- we can only make progs relocatable - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) - - supportsRelocatableProgs Hugs = True - supportsRelocatableProgs GHC = case buildOS of - Windows -> True - _ -> False - supportsRelocatableProgs _ = False - - paths_modulename = autogenModuleName pkg_descr - paths_filename = paths_modulename ++ ".hs" - paths_filepath = autogenModulesDir lbi paths_filename - - isHugs = compilerFlavor (compiler lbi) == Hugs - get_prefix_stuff - | isHugs = "progdirrel :: String\n"++ - "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ - get_prefix_hugs - | otherwise = get_prefix_win32 - - path_sep = show [pathSeparator] - -get_prefix_win32 :: String -get_prefix_win32 = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = do \n"++ - " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++ - " buf <- mallocArray len\n"++ - " ret <- getModuleFileName nullPtr buf len\n"++ - " if ret == 0 \n"++ - " then do free buf;\n"++ - " return (prefix `joinFileName` dirRel)\n"++ - " else do exePath <- peekCString buf\n"++ - " free buf\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ - "\n"++ - "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++ - " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n" +-- | Generate and write out the Paths_.hs and cabal_macros.h files +-- +writeAutogenFiles :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +writeAutogenFiles verbosity pkg lbi = do + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) -get_prefix_hugs :: String -get_prefix_hugs = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = do\n"++ - " mainPath <- getProgName\n"++ - " let (progPath,_) = splitFileName mainPath\n"++ - " let (progdir,_) = splitFileName progPath\n"++ - " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" + let pathsModulePath = autogenModulesDir lbi + ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" + rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) -filename_stuff :: String -filename_stuff = - "minusFileName :: FilePath -> String -> FilePath\n"++ - "minusFileName dir \"\" = dir\n"++ - "minusFileName dir \".\" = dir\n"++ - "minusFileName dir suffix =\n"++ - " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ - "\n"++ - "joinFileName :: String -> String -> FilePath\n"++ - "joinFileName \"\" fname = fname\n"++ - "joinFileName \".\" fname = fname\n"++ - "joinFileName dir \"\" = dir\n"++ - "joinFileName dir fname\n"++ - " | isPathSeparator (last dir) = dir++fname\n"++ - " | otherwise = dir++pathSeparator:fname\n"++ - "\n"++ - "splitFileName :: FilePath -> (String, String)\n"++ - "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ - " where\n"++ - " (path,drive) = case p of\n"++ - " (c:':':p') -> (reverse p',[':',c])\n"++ - " _ -> (reverse p ,\"\")\n"++ - " (fname,path1) = break isPathSeparator path\n"++ - " path2 = case path1 of\n"++ - " [] -> \".\"\n"++ - " [_] -> path1 -- don't remove the trailing slash if \n"++ - " -- there is only one character\n"++ - " (c:path') | isPathSeparator c -> path'\n"++ - " _ -> path1\n"++ - "\n"++ - "pathSeparator :: Char\n"++ - (case buildOS of - Windows -> "pathSeparator = '\\\\'\n" - _ -> "pathSeparator = '/'\n") ++ - "\n"++ - "isPathSeparator :: Char -> Bool\n"++ - (case buildOS of - Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" - _ -> "isPathSeparator c = c == '/'\n") + let cppHeaderPath = autogenModulesDir lbi cppHeaderName + rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) diff --git a/Distribution/Simple/Build/Macros.hs b/Distribution/Simple/Build/Macros.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Build/Macros.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +module Distribution.Simple.Build.Macros ( + generate + ) where + +import Distribution.Package + ( PackageIdentifier(PackageIdentifier) ) +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(packageDeps) ) +import Distribution.Text + ( display ) + +-- ------------------------------------------------------------ +-- * Generate cabal_macros.h +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate _pkg_descr lbi = concat $ + "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : + [ concat + ["/* package ",display pkgid," */\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) \\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor + ,"\n\n" + ] + | pkgid@(PackageIdentifier name version) <- packageDeps lbi + , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + pkgname = map fixchar (display name) + ] + where fixchar '-' = '_' + fixchar c = c + diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Build/PathsModule.hs @@ -0,0 +1,235 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +-- +module Distribution.Simple.Build.PathsModule ( + generate + ) where + +import Distribution.System + ( OS(Windows), buildOS ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor ) +import Distribution.Package + ( packageName, packageVersion ) +import Distribution.PackageDescription + ( PackageDescription(..), hasLibs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), InstallDirs(..) + , absoluteInstallDirs, prefixRelativeInstallDirs ) +import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) +import Distribution.Simple.BuildPaths + ( autogenModuleName ) +import Distribution.Text + ( display ) + +import System.FilePath + ( pathSeparator ) +import Data.Maybe + ( fromJust, isNothing ) + +-- ------------------------------------------------------------ +-- * Building Paths_.hs +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate pkg_descr lbi = + let pragmas + | absolute || isHugs = "" + | otherwise = + "{-# LANGUAGE ForeignFunctionInterface #-}\n" ++ + "{-# OPTIONS_GHC -fffi #-}\n"++ + "{-# OPTIONS_JHC -fffi #-}\n" + + foreign_imports + | absolute = "" + | isHugs = "import System.Environment\n" + | otherwise = + "import Foreign\n"++ + "import Foreign.C\n" + + header = + pragmas++ + "module " ++ display paths_modulename ++ " (\n"++ + " version,\n"++ + " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ + " getDataFileName\n"++ + " ) where\n"++ + "\n"++ + foreign_imports++ + "import Data.Version (Version(..))\n"++ + "import System.Environment (getEnv)"++ + "\n"++ + "\nversion :: Version"++ + "\nversion = " ++ show (packageVersion pkg_descr)++ + "\n" + + body + | absolute = + "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ + "\nbindir = " ++ show flat_bindir ++ + "\nlibdir = " ++ show flat_libdir ++ + "\ndatadir = " ++ show flat_datadir ++ + "\nlibexecdir = " ++ show flat_libexecdir ++ + "\n"++ + "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ + "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ + "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ + "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ + "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ + "\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir ++ "++path_sep++" ++ name)\n" + | otherwise = + "\nprefix, bindirrel :: FilePath" ++ + "\nprefix = " ++ show flat_prefix ++ + "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ + "\n\n"++ + "getBinDir :: IO FilePath\n"++ + "getBinDir = getPrefixDirRel bindirrel\n\n"++ + "getLibDir :: IO FilePath\n"++ + "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ + "getDataDir :: IO FilePath\n"++ + "getDataDir = "++ mkGetEnvOr "datadir" + (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ + "getLibexecDir :: IO FilePath\n"++ + "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir `joinFileName` name)\n"++ + "\n"++ + get_prefix_stuff++ + "\n"++ + filename_stuff + in header++body + + where + InstallDirs { + prefix = flat_prefix, + bindir = flat_bindir, + libdir = flat_libdir, + datadir = flat_datadir, + libexecdir = flat_libexecdir + } = absoluteInstallDirs pkg_descr lbi NoCopyDest + InstallDirs { + bindir = flat_bindirrel, + libdir = flat_libdirrel, + datadir = flat_datadirrel, + libexecdir = flat_libexecdirrel, + progdir = flat_progdirrel + } = prefixRelativeInstallDirs pkg_descr lbi + + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++ + " (\\_ -> "++expr++")" + where var' = showPkgName (packageName pkg_descr) ++ "_" ++ var + showPkgName = map fixchar . display + fixchar '-' = '_' + fixchar c = c + + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + supportsRelocatableProgs Hugs = True + supportsRelocatableProgs GHC = case buildOS of + Windows -> True + _ -> False + supportsRelocatableProgs _ = False + + paths_modulename = autogenModuleName pkg_descr + + isHugs = compilerFlavor (compiler lbi) == Hugs + get_prefix_stuff + | isHugs = "progdirrel :: String\n"++ + "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ + get_prefix_hugs + | otherwise = get_prefix_win32 + + path_sep = show [pathSeparator] + +get_prefix_win32 :: String +get_prefix_win32 = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = do \n"++ + " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++ + " buf <- mallocArray len\n"++ + " ret <- getModuleFileName nullPtr buf len\n"++ + " if ret == 0 \n"++ + " then do free buf;\n"++ + " return (prefix `joinFileName` dirRel)\n"++ + " else do exePath <- peekCString buf\n"++ + " free buf\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + "\n"++ + "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++ + " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n" + +get_prefix_hugs :: String +get_prefix_hugs = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = do\n"++ + " mainPath <- getProgName\n"++ + " let (progPath,_) = splitFileName mainPath\n"++ + " let (progdir,_) = splitFileName progPath\n"++ + " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" + +filename_stuff :: String +filename_stuff = + "minusFileName :: FilePath -> String -> FilePath\n"++ + "minusFileName dir \"\" = dir\n"++ + "minusFileName dir \".\" = dir\n"++ + "minusFileName dir suffix =\n"++ + " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ + "\n"++ + "joinFileName :: String -> String -> FilePath\n"++ + "joinFileName \"\" fname = fname\n"++ + "joinFileName \".\" fname = fname\n"++ + "joinFileName dir \"\" = dir\n"++ + "joinFileName dir fname\n"++ + " | isPathSeparator (last dir) = dir++fname\n"++ + " | otherwise = dir++pathSeparator:fname\n"++ + "\n"++ + "splitFileName :: FilePath -> (String, String)\n"++ + "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ + " where\n"++ + " (path,drive) = case p of\n"++ + " (c:':':p') -> (reverse p',[':',c])\n"++ + " _ -> (reverse p ,\"\")\n"++ + " (fname,path1) = break isPathSeparator path\n"++ + " path2 = case path1 of\n"++ + " [] -> \".\"\n"++ + " [_] -> path1 -- don't remove the trailing slash if \n"++ + " -- there is only one character\n"++ + " (c:path') | isPathSeparator c -> path'\n"++ + " _ -> path1\n"++ + "\n"++ + "pathSeparator :: Char\n"++ + (case buildOS of + Windows -> "pathSeparator = '\\\\'\n" + _ -> "pathSeparator = '/'\n") ++ + "\n"++ + "isPathSeparator :: Char -> Bool\n"++ + (case buildOS of + Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" + _ -> "isPathSeparator c = c == '/'\n") diff --git a/Distribution/Simple/BuildPaths.hs b/Distribution/Simple/BuildPaths.hs --- a/Distribution/Simple/BuildPaths.hs +++ b/Distribution/Simple/BuildPaths.hs @@ -4,8 +4,7 @@ -- Copyright : Isaac Jones 2003-2004, -- Duncan Coutts 2008 -- --- Maintainer : Isaac Jones --- Stability : alpha +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A bunch of dirs, paths and file names used for intermediate build steps. @@ -47,6 +46,7 @@ autogenModulesDir, autogenModuleName, + cppHeaderName, haddockName, mkLibName, @@ -64,6 +64,8 @@ import Distribution.Package ( PackageIdentifier, packageName ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName import Distribution.Compiler ( CompilerId(..) ) import Distribution.PackageDescription (PackageDescription) @@ -84,22 +86,24 @@ haddockPref :: FilePath -> PackageDescription -> FilePath haddockPref distPref pkg_descr - = distPref "doc" "html" packageName pkg_descr + = distPref "doc" "html" display (packageName pkg_descr) -- |The directory in which we put auto-generated modules autogenModulesDir :: LocalBuildInfo -> String autogenModulesDir lbi = buildDir lbi "autogen" +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" -- |The name of the auto-generated module associated with a package -autogenModuleName :: PackageDescription -> String +autogenModuleName :: PackageDescription -> ModuleName autogenModuleName pkg_descr = - "Paths_" ++ map fixchar (packageName pkg_descr) + ModuleName.simple $ "Paths_" ++ map fixchar (display (packageName pkg_descr)) where fixchar '-' = '_' fixchar c = c haddockName :: PackageDescription -> FilePath -haddockName pkg_descr = packageName pkg_descr <.> "haddock" +haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" -- --------------------------------------------------------------------------- -- Library file names @@ -120,7 +124,7 @@ -- ------------------------------------------------------------ -- * Platform file extensions --- ------------------------------------------------------------ +-- ------------------------------------------------------------ -- ToDo: This should be determined via autoconf (AC_EXEEXT) -- | Extension for executable files diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs --- a/Distribution/Simple/Command.hs +++ b/Distribution/Simple/Command.hs @@ -2,13 +2,17 @@ -- | -- Module : Distribution.Simple.Command -- Copyright : Duncan Coutts 2007 --- --- Maintainer : Duncan Coutts --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Data types and parser for the standard command-line --- setup. +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- command line completion flags. It is designed to allow other tools make +-- derived commands. This feature is used heavily in @cabal-install@. {- All rights reserved. @@ -45,7 +49,7 @@ -- * Command interface CommandUI(..), commandShowOptions, - + -- ** Constructing commands ShowOrParseArgs(..), makeCommand, @@ -54,7 +58,7 @@ Command, commandAddAction, noExtraFlags, - + -- ** Running commands CommandParse(..), commandsRun, @@ -402,24 +406,33 @@ commandParseArgs :: CommandUI flags -> Bool -> [String] -> CommandParse (flags -> flags, [String]) -commandParseArgs command ordered args = +commandParseArgs command global args = let options = addCommonFlags ParseArgs $ commandGetOpts ParseArgs command - order | ordered = GetOpt.RequireOrder + order | global = GetOpt.RequireOrder | otherwise = GetOpt.Permute - in case GetOpt.getOpt order options args of - (flags, _, _) - | not (null [ () | Left ListOptionsFlag <- flags ]) - -> CommandList (commandListOptions command) - | not (null [ () | Left HelpFlag <- flags ]) - -> CommandHelp (commandHelp command) - (flags, opts, []) -> CommandReadyToGo (accumFlags flags , opts) - (_, _, errs) -> CommandErrors errs + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs where -- Note: It is crucial to use reverse function composition here or to -- reverse the flags here as we want to process the flags left to right -- but data flow in function compsition is right to left. - accumFlags flags = foldr (flip (.)) id [ f | Right f <- flags ] + accum flags = foldr (flip (.)) id [ f | Right f <- flags ] + unrecognised opts = [ "unrecognized option `" ++ opt ++ "'\n" + | opt <- opts ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x:xs) ys = x:ys++xs data CommandParse flags = CommandHelp (String -> String) | CommandList [String] @@ -434,8 +447,7 @@ data Command action = Command String String ([String] -> CommandParse action) -commandAddAction :: Monoid flags - => CommandUI flags +commandAddAction :: CommandUI flags -> (flags -> [String] -> action) -> Command action commandAddAction command action = @@ -445,8 +457,7 @@ . commandParseArgs command False) where applyDefaultArgs mkflags args = - let flags = commandDefaultFlags command - `mappend` mkflags mempty + let flags = mkflags (commandDefaultFlags command) in action flags args commandsRun :: CommandUI a diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -2,12 +2,20 @@ -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Haskell implementations. +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like it's flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- per-user one and it lets you create arbitrary other package databases. We do +-- not yet fully support this latter feature. {- All rights reserved. @@ -41,8 +49,8 @@ module Distribution.Simple.Compiler ( -- * Haskell implementations - module Distribution.Compiler, - Compiler(..), + module Distribution.Compiler, + Compiler(..), showCompilerId, compilerFlavor, compilerVersion, -- * Support for package databases @@ -68,7 +76,7 @@ data Compiler = Compiler { compilerId :: CompilerId, - compilerExtensions :: [(Extension, String)] + compilerExtensions :: [(Extension, String)] } deriving (Show, Read) diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -2,13 +2,23 @@ -- | -- Module : Distribution.Simple.Configure -- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Perform the \"@.\/setup configure@\" action. --- Outputs the @dist\/setup-config@ file. +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. {- All rights reserved. @@ -48,7 +58,7 @@ -- getConfiguredPkgDescr, localBuildInfoFile, getInstalledPackages, - configDependency, + configDependency, configCompiler, configCompilerAux, ccLdOptionsBuildInfo, tryGetConfigStateFile, @@ -59,8 +69,8 @@ ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion , showCompilerId, unsupportedExtensions, PackageDB(..) ) import Distribution.Package - ( PackageIdentifier(PackageIdentifier), packageVersion, Package(..) - , Dependency(Dependency) ) + ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) + , packageVersion, Package(..), Dependency(Dependency) ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, emptyInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -81,7 +91,7 @@ ( Program(..), ProgramLocation(..), ConfiguredProgram(..) , ProgramConfiguration, defaultProgramConfiguration , configureAllKnownPrograms, knownPrograms - , userSpecifyArgs, userSpecifyPath + , userSpecifyArgss, userSpecifyPaths , lookupKnownProgram, requireProgram, pkgConfigProgram , rawSystemProgramStdoutConf ) import Distribution.Simple.Setup @@ -93,7 +103,8 @@ , prefixRelativeInstallDirs ) import Distribution.Simple.Utils ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose - , intercalate, comparing, cabalVersion, cabalBootstrapping ) + , intercalate, comparing, cabalVersion, cabalBootstrapping + , withFileContents, writeFileAtomic ) import Distribution.Simple.Register ( removeInstalledConfig ) import Distribution.System @@ -110,8 +121,6 @@ import Control.Monad ( when, unless, foldM ) -import Control.Exception as Exception - ( catch ) import Data.List ( nub, partition, isPrefixOf, maximumBy ) import Data.Maybe @@ -127,12 +136,13 @@ import qualified System.Info ( compilerName, compilerVersion ) import System.IO - ( hPutStrLn, stderr, hGetContents, openFile, hClose, IOMode(ReadMode) ) + ( hPutStrLn, stderr ) import Distribution.Text ( Text(disp), display, simpleParse ) import Text.PrettyPrint.HughesPJ ( comma, punctuate, render, nest, sep ) - +import Distribution.Compat.Exception ( catchExit, catchIO ) + import Prelude hiding (catch) tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) @@ -140,21 +150,15 @@ exists <- doesFileExist filename if not exists then return (Left missing) - else do - str <- readFileStrict filename - return $ case lines str of + else withFileContents filename $ \str -> + case lines str of [headder, rest] -> case checkHeader headder of - Just msg -> Left msg + Just msg -> return (Left msg) Nothing -> case reads rest of - [(bi,_)] -> Right bi - _ -> Left cantParse - _ -> Left cantParse + [(bi,_)] -> return (Right bi) + _ -> return (Left cantParse) + _ -> return (Left cantParse) where - readFileStrict name = do - h <- openFile name ReadMode - str <- hGetContents h >>= \str -> length str `seq` return str - hClose h - return str checkHeader :: String -> Maybe String checkHeader header = case parseHeader header of Just (cabalId, compId) @@ -203,8 +207,8 @@ writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () writePersistBuildConfig distPref lbi = do createDirectoryIfMissing False distPref - writeFile (localBuildInfoFile distPref) - (showHeader pkgid ++ '\n' : show lbi) + writeFileAtomic (localBuildInfoFile distPref) + (showHeader pkgid ++ '\n' : show lbi) where pkgid = packageId (localPkgDescr lbi) @@ -216,15 +220,15 @@ where currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier "Cabal" currentVersion +currentCabalId = PackageIdentifier (PackageName "Cabal") currentVersion where currentVersion | cabalBootstrapping = Version [0] [] | otherwise = cabalVersion currentCompilerId :: PackageIdentifier -currentCompilerId = PackageIdentifier System.Info.compilerName +currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) System.Info.compilerVersion -parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) +parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) parseHeader header = case words header of ["Saved", "package", "config", "for", pkgid, "written", "by", cabalid, "using", compilerid] @@ -257,31 +261,28 @@ -- |Perform the \"@.\/setup configure@\" action. -- Returns the @.setup-config@ file. configure :: ( Either GenericPackageDescription PackageDescription - , HookedBuildInfo) + , HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo configure (pkg_descr0, pbi) cfg = do let distPref = fromFlag (configDistPref cfg) verbosity = fromFlag (configVerbosity cfg) - setupMessage verbosity "Configuring" + setupMessage verbosity "Configuring" (packageId (either packageDescription id pkg_descr0)) - createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref + createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref - let programsConfig = - flip (foldl userSpecifyArgs') (configProgramArgs cfg) - . flip (foldl userSpecifyPath') (configProgramPaths cfg) - $ configPrograms cfg - userSpecifyArgs' conf (prog, args) = userSpecifyArgs prog args conf - userSpecifyPath' conf (prog, path) = userSpecifyPath prog path conf + let programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ configPrograms cfg userInstall = fromFlag (configUserInstall cfg) - defaultPackageDB | userInstall = UserPackageDB - | otherwise = GlobalPackageDB - packageDb = fromFlagOrDefault defaultPackageDB - (configPackageDB cfg) + defaultPackageDB | userInstall = UserPackageDB + | otherwise = GlobalPackageDB + packageDb = fromFlagOrDefault defaultPackageDB + (configPackageDB cfg) - -- detect compiler - (comp, programsConfig') <- configCompiler + -- detect compiler + (comp, programsConfig') <- configCompiler (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) programsConfig (lessVerbose verbosity) @@ -289,26 +290,26 @@ flavor = compilerFlavor comp -- FIXME: currently only GHC has hc-pkg - maybePackageIndex <- getInstalledPackages (lessVerbose verbosity) comp + maybePackageSet <- getInstalledPackages (lessVerbose verbosity) comp packageDb programsConfig' (pkg_descr0', flags) <- case pkg_descr0 of - Left ppd -> - case finalizePackageDescription + Left ppd -> + case finalizePackageDescription (configConfigurationsFlags cfg) - maybePackageIndex + maybePackageSet Distribution.System.buildOS Distribution.System.buildArch (compilerId comp) (configConstraints cfg) ppd of Right r -> return r - Left missing -> + Left missing -> die $ "At least the following dependencies are missing:\n" - ++ (render . nest 4 . sep . punctuate comma $ + ++ (render . nest 4 . sep . punctuate comma $ map disp missing) Right pd -> return (pd,[]) - + -- add extra include/lib dirs as specified in cfg -- we do it here so that those get checked too let pkg_descr = addExtraIncludeLibDirs pkg_descr0' @@ -322,7 +323,7 @@ (either Just (\_->Nothing) pkg_descr0) --TODO: make the Either go away (updatePackageDescription pbi pkg_descr) - let packageIndex = fromMaybe bogusPackageIndex maybePackageIndex + let packageSet = fromMaybe bogusPackageSet maybePackageSet -- FIXME: For Hugs, nhc98 and other compilers we do not know what -- packages are already installed, so we just make some up, pretend -- that they do exist and just hope for the best. We make them up @@ -330,19 +331,19 @@ -- happens to depend on. See 'inventBogusPackageId' below. -- Let's hope they really are installed... :-) bogusDependencies = map inventBogusPackageId (buildDepends pkg_descr) - bogusPackageIndex = PackageIndex.fromList + bogusPackageSet = PackageIndex.fromList [ emptyInstalledPackageInfo { InstalledPackageInfo.package = bogusPackageId -- note that these bogus packages have no other dependencies } | bogusPackageId <- bogusDependencies ] dep_pkgs <- case flavor of - GHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr) - JHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr) + GHC -> mapM (configDependency verbosity packageSet) (buildDepends pkg_descr) + JHC -> mapM (configDependency verbosity packageSet) (buildDepends pkg_descr) _ -> return bogusDependencies packageDependsIndex <- - case PackageIndex.dependencyClosure packageIndex dep_pkgs of + case PackageIndex.dependencyClosure packageSet dep_pkgs of Left packageDependsIndex -> return packageDependsIndex Right broken -> die $ "The following installed packages are broken because other" @@ -371,11 +372,11 @@ | (name, uses) <- inconsistencies , (pkg, ver) <- uses ] - removeInstalledConfig distPref + removeInstalledConfig distPref - -- installation directories - defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) - let installDirs = combineInstallDirs fromFlagOrDefault + -- installation directories + defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) + let installDirs = combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs cfg) -- check extensions @@ -389,41 +390,41 @@ programsConfig'' <- configureAllKnownPrograms (lessVerbose verbosity) programsConfig' >>= configureRequiredPrograms verbosity requiredBuildTools - + (pkg_descr', programsConfig''') <- configurePkgconfigPackages verbosity pkg_descr programsConfig'' - split_objs <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case flavor of - GHC | version >= Version [6,5] [] -> return True - _ -> do warn verbosity + split_objs <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case flavor of + GHC | version >= Version [6,5] [] -> return True + _ -> do warn verbosity ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False + "--enable-split-objs; ignoring") + return False - let lbi = LocalBuildInfo{ - installDirTemplates = installDirs, - compiler = comp, - buildDir = distPref "build", - scratchDir = fromFlagOrDefault + let lbi = LocalBuildInfo{ + installDirTemplates = installDirs, + compiler = comp, + buildDir = distPref "build", + scratchDir = fromFlagOrDefault (distPref "scratch") (configScratchDir cfg), - packageDeps = dep_pkgs, + packageDeps = dep_pkgs, installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programsConfig''', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withProfLib = fromFlag $ configProfLib cfg, - withSharedLib = fromFlag $ configSharedLib cfg, - withProfExe = fromFlag $ configProfExe cfg, - withOptimization = fromFlag $ configOptimization cfg, - withGHCiLib = fromFlag $ configGHCiLib cfg, - splitObjs = split_objs, + localPkgDescr = pkg_descr', + withPrograms = programsConfig''', + withVanillaLib = fromFlag $ configVanillaLib cfg, + withProfLib = fromFlag $ configProfLib cfg, + withSharedLib = fromFlag $ configSharedLib cfg, + withProfExe = fromFlag $ configProfExe cfg, + withOptimization = fromFlag $ configOptimization cfg, + withGHCiLib = fromFlag $ configGHCiLib cfg, + splitObjs = split_objs, stripExes = fromFlag $ configStripExes cfg, - withPackageDB = packageDb, + withPackageDB = packageDb, progPrefix = fromFlag $ configProgPrefix cfg, progSuffix = fromFlag $ configProgSuffix cfg } @@ -456,7 +457,7 @@ sequence_ [ reportProgram verbosity prog configuredProg | (prog, configuredProg) <- knownPrograms programsConfig''' ] - return lbi + return lbi where addExtraIncludeLibDirs pkg_descr = @@ -496,15 +497,14 @@ -- | Test for a package dependency and record the version we have installed. configDependency :: Verbosity -> PackageIndex InstalledPackageInfo -> Dependency -> IO PackageIdentifier -configDependency verbosity index dep@(Dependency pkgname vrange) = +configDependency verbosity index dep@(Dependency pkgname _) = case PackageIndex.lookupDependency index dep of [] -> die $ "cannot satisfy dependency " - ++ pkgname ++ display vrange ++ "\n" + ++ display dep ++ "\n" ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ pkgname ++ "?" + ++ hackageUrl ++ display pkgname ++ "?" pkgs -> do let pkgid = maximumBy (comparing packageVersion) (map packageId pkgs) - info verbosity $ "Dependency " ++ pkgname - ++ display vrange + info verbosity $ "Dependency " ++ display dep ++ ": using " ++ display pkgid return pkgid @@ -525,9 +525,9 @@ foldM (configureRequiredProgram verbosity) conf deps configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration -configureRequiredProgram verbosity conf (Dependency progName verRange) = +configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = case lookupKnownProgram progName conf of - Nothing -> die ("Unknown build tool " ++ show progName) + Nothing -> die ("Unknown build tool " ++ progName) Just prog -> snd `fmap` requireProgram verbosity prog verRange conf -- ----------------------------------------------------------------------------- @@ -546,26 +546,27 @@ exes' <- mapM updateExecutable (executables pkg_descr) let pkg_descr' = pkg_descr { library = lib', executables = exes' } return (pkg_descr', conf') - - where + + where allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) pkgConfigProgram conf - requirePkg (Dependency pkg range) = do + requirePkg dep@(Dependency (PackageName pkg) range) = do version <- pkgconfig ["--modversion", pkg] - `Exception.catch` \_ -> die notFound + `catchIO` (\_ -> die notFound) + `catchExit` (\_ -> die notFound) case simpleParse version of Nothing -> die "parsing output of pkg-config --modversion failed" Just v | not (withinRange v range) -> die (badVersion v) | otherwise -> info verbosity (depSatisfied v) - where + where notFound = "The pkg-config package " ++ pkg ++ versionRequirement ++ " is required but it could not be found." badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement ++ " is required but the version installed on the" ++ " system is version " ++ display v - depSatisfied v = "Dependency " ++ pkg ++ display range + depSatisfied v = "Dependency " ++ display dep ++ ": using version " ++ display v versionRequirement @@ -583,7 +584,7 @@ pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ pkg | Dependency pkg _ <- pkgdeps ] + let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] ccflags <- pkgconfig ("--cflags" : pkgs) ldflags <- pkgconfig ("--libs" : pkgs) return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) @@ -662,12 +663,12 @@ do let simonMarGHCLoc = "/usr/bin/ghc" simonMarGHC <- configure emptyPackageDescription {package=packageID} (Just GHC, - Just simonMarGHCLoc, - Nothing, Nothing) - assertEqual "finding ghc, etc on simonMar's machine failed" - (LocalBuildInfo "/usr" (Compiler GHC - (Version [6,2,2] []) simonMarGHCLoc - (simonMarGHCLoc ++ "-pkg")) [] []) + Just simonMarGHCLoc, + Nothing, Nothing) + assertEqual "finding ghc, etc on simonMar's machine failed" + (LocalBuildInfo "/usr" (Compiler GHC + (Version [6,2,2] []) simonMarGHCLoc + (simonMarGHCLoc ++ "-pkg")) [] []) simonMarGHC ] -} diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -2,14 +2,35 @@ -- | -- Module : Distribution.Simple.GHC -- Copyright : Isaac Jones 2003-2007 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Build and Install implementations for GHC. See --- 'Distribution.Simple.GHC.PackageConfig.GHCPackageConfig' for --- registration-related stuff. +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- There is also some code for generating @Makefiles@ but the less said about +-- that the better. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -49,32 +70,38 @@ ) where import Distribution.Simple.GHC.Makefile -import Distribution.Simple.Setup ( MakefileFlags(..), +import qualified Distribution.Simple.GHC.IPI641 as IPI641 +import qualified Distribution.Simple.GHC.IPI642 as IPI642 +import Distribution.Simple.Setup ( CopyFlags(..), MakefileFlags(..), fromFlag, fromFlagOrDefault) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), - withLib, - Executable(..), withExe, Library(..), - libModules, hcOptions ) +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), + withLib, + Executable(..), withExe, Library(..), + libModules, hcOptions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo , parseInstalledPackageInfo ) -import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) ) + ( LocalBuildInfo(..), InstallDirs(..) ) +import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package - ( PackageIdentifier, Package(..) ) + ( PackageIdentifier, Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration - , rawSystemProgram, rawSystemProgramConf + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf , rawSystemProgramStdout, rawSystemProgramStdoutConf, requireProgram - , userMaybeSpecifyPath, programPath, lookupProgram, updateProgram + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram , ghcProgram, ghcPkgProgram, arProgram, ranlibProgram, ldProgram - , stripProgram ) + , gccProgram, stripProgram ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , OptimisationLevel(..), PackageDB(..), Flag, extensionsToFlags ) @@ -87,19 +114,18 @@ ( display, simpleParse ) import Language.Haskell.Extension (Extension(..)) -import Control.Monad ( unless, when ) +import Control.Monad ( unless, when ) import Data.Char -import Data.List ( nub ) +import Data.List import Data.Maybe ( catMaybes ) -import Data.Monoid ( Monoid(mconcat) ) -import System.Directory ( removeFile, renameFile, - getDirectoryContents, doesFileExist, - getTemporaryDirectory ) +import System.Directory ( removeFile, renameFile, + getDirectoryContents, doesFileExist, + getTemporaryDirectory ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory, replaceExtension, splitExtension ) import System.IO (openFile, IOMode(WriteMode), hClose, hPutStrLn) -import Control.Exception as Exception - ( catch, handle, try ) +import Distribution.Compat.Exception (catchExit, catchIO) +import Distribution.Compat.Permissions (copyPermissions) -- ----------------------------------------------------------------------------- -- Configuring @@ -108,7 +134,7 @@ -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf = do - (ghcProg, conf') <- requireProgram verbosity ghcProgram + (ghcProg, conf') <- requireProgram verbosity ghcProgram (orLaterVersion (Version [6,4] [])) (userMaybeSpecifyPath "ghc" hcPath conf) let Just ghcVersion = programVersion ghcProg @@ -128,39 +154,6 @@ ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion - -- finding ghc's local ld is a bit tricky as it's not on the path: - let ldProgram' = case buildOS of - Windows -> - let compilerDir = takeDirectory (programPath ghcProg) - baseDir = takeDirectory compilerDir - binInstallLd = baseDir "gcc-lib" "ld.exe" - in ldProgram { - programFindLocation = \_ -> return (Just binInstallLd) - } - _ -> ldProgram - - -- we need to find out if ld supports the -x flag - (ldProg, conf''') <- requireProgram verbosity ldProgram' AnyVersion conf'' - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() {}" - hClose testchnd; hClose testohnd - rawSystemProgram verbosity ghcProg ["-c", testcfile, - "-o", testofile] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - handle (\_ -> return False) $ do - hClose testohnd' - rawSystemProgramStdout verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - let conf'''' = updateProgram ldProg { - programArgs = if ldx then ["-x"] else [] - } conf''' - -- Yeah yeah, so obviously conf''''' is totally rediculious and the program - -- configuration needs to be in a state monad. That is exactly the plan - -- (along with some other stuff to give Cabal a better DSL). - languageExtensions <- if ghcVersion >= Version [6,7] [] then do exts <- rawSystemStdout verbosity (programPath ghcProg) @@ -180,7 +173,8 @@ compilerId = CompilerId GHC ghcVersion, compilerExtensions = languageExtensions } - return (comp, conf'''') + conf''' = configureToolchain ghcProg conf'' -- configure gcc and ld + return (comp, conf''') -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding ghc-pkg, we try looking for both a versioned and unversioned @@ -195,7 +189,7 @@ dir = takeDirectory path versionSuffix = takeVersionSuffix (dropExeExtension path) guessNormal = dir "ghc-pkg" <.> exeExtension - guessVersioned = dir ("ghc-pkg" ++ versionSuffix) <.> exeExtension + guessVersioned = dir ("ghc-pkg" ++ versionSuffix) <.> exeExtension guesses | null versionSuffix = [guessNormal] | otherwise = [guessVersioned, guessNormal] info verbosity $ "looking for package tool: ghc-pkg near compiler in " ++ dir @@ -214,6 +208,66 @@ (filepath', extension) | extension == exeExtension -> filepath' | otherwise -> filepath +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain ghcProg = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram (baseDir "gcc.exe"), + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram (libDir "ld.exe"), + programPostConf = configureLd + } + where + compilerDir = takeDirectory (programPath ghcProg) + baseDir = takeDirectory compilerDir + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath) + findProg prog location | isWindows = \_ -> do + exists <- doesFileExist location + if exists then return (Just location) else return Nothing + | otherwise = programFindLocation prog + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- that means we should add this extra flag to tell ghc's gcc + -- where it lives and thus where gcc can find its various files: + FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir] + UserSpecified {} -> return [] + | otherwise = \_ _ -> return [] + + -- we need to find out if ld supports the -x flag + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity ghcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ["-x"] + else return [] + -- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags oldLanguageExtensions :: [(Extension, Flag)] oldLanguageExtensions = @@ -269,9 +323,29 @@ GlobalPackageDB -> [GlobalPackageDB] _ -> [GlobalPackageDB, packagedb] pkgss <- getInstalledPackages' verbosity packagedbs conf - return $ mconcat [ PackageIndex.fromList pkgs - | (_, pkgs) <- pkgss ] + let pkgs = concatMap snd pkgss + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram ghcProgram conf + compilerDir = takeDirectory (programPath ghcProg) + topDir = takeDirectory compilerDir + pkgs' = map (substTopDir topDir) pkgs + pi1 = PackageIndex.fromList pkgs' + rtsPackages = lookupPackageName pi1 (PackageName "rts") + rtsPackages' = map removeMingwIncludeDir rtsPackages + pi2 = pi1 `merge` fromList rtsPackages' + return pi2 +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg { InstalledPackageInfo.includeDirs = ids' } + -- | Get the packages from specific PackageDBs, not cumulative. -- getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration @@ -280,15 +354,11 @@ | ghcVersion >= Version [6,9] [] = sequence [ do str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf - ["describe", "*", packageDbGhcPkgFlag packagedb] - `Exception.catch` \_ -> die $ - "ghc-pkg describe * failed. If you are using ghc-6.9 " - ++ "and have an empty user package database then this " - ++ "is probably due to ghc bug #2201. The workaround is to " - ++ "register at least one package in the user package db." + ["dump", packageDbGhcPkgFlag packagedb] + `catchExit` \_ -> die $ "ghc-pkg dump failed" case parsePackages str of - Left ok -> return (packagedb, ok) - _ -> die "failed to parse output of 'ghc-pkg describe *'" + Left ok -> return (packagedb, ok) + _ -> die "failed to parse output of 'ghc-pkg dump'" | packagedb <- packagedbs ] where @@ -302,13 +372,13 @@ Just ghcVersion = programVersion ghcProg splitPkgs :: String -> [String] - splitPkgs = map unlines . split [] . lines - where split [] [] = [] - split acc [] = [reverse acc] - split acc (l@('n':'a':'m':'e':':':_):ls) - | null acc = split (l:[]) ls - | otherwise = reverse acc : split (l:[]) ls - split acc (l:ls) = split (l:acc) ls + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs packageDbGhcPkgFlag GlobalPackageDB = "--global" packageDbGhcPkgFlag UserPackageDB = "--user" @@ -324,12 +394,46 @@ (SpecificPackageDB specific, _) -> return $ Just specific _ -> die "cannot read ghc-pkg package listing" pkgFiles' <- mapM dbFile packagedbs - sequence [ withFileContents file $ \content -> - case reads content of - [(pkgs, _)] -> return (db, pkgs) - _ -> die $ "cannot read ghc package database " ++ file + sequence [ withFileContents file $ \content -> do + pkgs <- readPackages file content + return (db, pkgs) | (db , Just file) <- zip packagedbs pkgFiles' ] + where + -- Depending on the version of ghc we use a different type's Read + -- instance to parse the package file and then convert. + -- It's a bit yuck. But that's what we get for using Read/Show. + readPackages + | ghcVersion >= Version [6,4,2] [] + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI642.toCurrent pkgs) + _ -> failToRead file + | otherwise + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI641.toCurrent pkgs) + _ -> failToRead file + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + failToRead file = die $ "cannot read ghc package database " ++ file +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + -- ----------------------------------------------------------------------------- -- Building @@ -350,15 +454,15 @@ info verbosity "Building library..." let libBi = libBuildInfo lib libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` extensions libBi - -- TH always needs vanilla libs, even when building for profiling + forceVanillaLib = TemplateHaskell `elem` extensions libBi + -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recurive modules? let ghcArgs = ["-package-name", display pkgid ] ++ constructGHCCmdLine lbi libBi libTargetDir verbosity - ++ (libModules pkg_descr) + ++ map display (libModules pkg_descr) ghcArgsProf = ghcArgs ++ ["-prof", "-hisuf", "p_hi", @@ -379,7 +483,7 @@ -- build any C sources unless (null (cSources libBi)) $ do info verbosity "Building C Sources..." - sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi pref + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi pref filename verbosity createDirectoryIfMissingVerbose verbosity True odir runGhcProg args @@ -389,7 +493,7 @@ -- link: info verbosity "Linking..." let cObjs = map (`replaceExtension` objExtension) (cSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) vanillaLibFilePath = libTargetDir mkLibName pkgid profileLibFilePath = libTargetDir mkProfLibName pkgid sharedLibFilePath = libTargetDir mkSharedLibName pkgid @@ -398,34 +502,34 @@ stubObjs <- fmap catMaybes $ sequence [ findFileWithExtension [objExtension] [libTargetDir] - (dotToSep x ++"_stub") + (ModuleName.toFilePath x ++"_stub") | x <- libModules pkg_descr ] stubProfObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (dotToSep x ++"_stub") + (ModuleName.toFilePath x ++"_stub") | x <- libModules pkg_descr ] stubSharedObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (dotToSep x ++"_stub") + (ModuleName.toFilePath x ++"_stub") | x <- libModules pkg_descr ] hObjs <- getHaskellObjects pkg_descr libBi lbi - pref objExtension True - hProfObjs <- - if (withProfLib lbi) - then getHaskellObjects pkg_descr libBi lbi - pref ("p_" ++ objExtension) True - else return [] + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects pkg_descr libBi lbi + pref ("p_" ++ objExtension) True + else return [] hSharedObjs <- - if (withSharedLib lbi) - then getHaskellObjects pkg_descr libBi lbi - pref ("dyn_" ++ objExtension) False - else return [] + if (withSharedLib lbi) + then getHaskellObjects pkg_descr libBi lbi + pref ("dyn_" ++ objExtension) False + else return [] unless (null hObjs && null cObjs && null stubObjs) $ do -- first remove library files if they exists sequence_ - [ try (removeFile libFilePath) + [ removeFile libFilePath `catchIO` \_ -> return () | libFilePath <- [vanillaLibFilePath, profileLibFilePath ,sharedLibFilePath, ghciLibFilePath] ] @@ -435,44 +539,45 @@ arArgs = ["q"++ arVerbosity] ++ [vanillaLibFilePath] arObjArgs = - hObjs + hObjs ++ map (pref ) cObjs ++ stubObjs arProfArgs = ["q"++ arVerbosity] ++ [profileLibFilePath] arProfObjArgs = - hProfObjs + hProfObjs ++ map (pref ) cObjs ++ stubProfObjs - ldArgs = ["-r"] - ++ ["-o", ghciLibFilePath <.> "tmp"] + ldArgs = ["-r"] + ++ ["-o", ghciLibFilePath <.> "tmp"] ldObjArgs = - hObjs + hObjs ++ map (pref ) cObjs - ++ stubObjs + ++ stubObjs ghcSharedObjArgs = - hSharedObjs + hSharedObjs ++ map (pref ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - [ "-shared", - "-dynamic", - "-o", sharedLibFilePath ] - ++ ghcSharedObjArgs - ++ ["-package-name", display pkgid ] - ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) - ++ ["-l"++extraLib | extraLib <- extraLibs libBi] - ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + ++ ghcSharedObjArgs + ++ ["-package-name", display pkgid ] + ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] runLd ldLibName args = do exists <- doesFileExist ldLibName - -- This method is called iteratively by xargs. The - -- output goes to .tmp, and any existing file - -- named is included when linking. The - -- output is renamed to . + -- This method is called iteratively by xargs. The + -- output goes to .tmp, and any existing file + -- named is included when linking. The + -- output is renamed to . rawSystemProgramConf verbosity ldProgram (withPrograms lbi) (args ++ if exists then [ldLibName] else []) renameFile (ldLibName <.> "tmp") ldLibName @@ -505,7 +610,7 @@ let exeNameReal = exeName' <.> (if null $ takeExtension exeName' then exeExtension else "") - let targetDir = pref exeName' + let targetDir = pref exeName' let exeDir = targetDir (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir @@ -515,7 +620,7 @@ -- build executables unless (null (cSources exeBi)) $ do info verbosity "Building C Sources." - sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi exeDir filename verbosity createDirectoryIfMissingVerbose verbosity True odir runGhcProg args @@ -525,16 +630,16 @@ let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) let binArgs linkExe profExe = - (if linkExe - then ["-o", targetDir exeNameReal] + (if linkExe + then ["-o", targetDir exeNameReal] else ["-c"]) ++ constructGHCCmdLine lbi exeBi exeDir verbosity ++ [exeDir x | x <- cObjs] ++ [srcMainFile] - ++ ldOptions exeBi - ++ ["-l"++lib | lib <- extraLibs exeBi] - ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] - ++ concat [["-framework", f] | f <- frameworks exeBi] + ++ PD.ldOptions exeBi + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] ++ if profExe then ["-prof", "-hisuf", "p_hi", @@ -542,33 +647,33 @@ ] ++ ghcProfOptions exeBi else [] - -- For building exe's for profiling that use TH we actually - -- have to build twice, once without profiling and the again - -- with profiling. This is because the code that TH needs to - -- run at compile time needs to be the vanilla ABI so it can - -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi) - (runGhcProg (binArgs False False)) + -- For building exe's for profiling that use TH we actually + -- have to build twice, once without profiling and the again + -- with profiling. This is because the code that TH needs to + -- run at compile time needs to be the vanilla ABI so it can + -- be loaded up and run by the compiler. + when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi) + (runGhcProg (binArgs False False)) - runGhcProg (binArgs True (withProfExe lbi)) + runGhcProg (binArgs True (withProfExe lbi)) -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: PackageDescription -> BuildInfo -> LocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] + -> FilePath -> String -> Bool -> IO [FilePath] getHaskellObjects pkg_descr _ lbi pref wanted_obj_ext allow_split_objs | splitObjs lbi && allow_split_objs = do - let dirs = [ pref (dotToSep x ++ "_split") - | x <- libModules pkg_descr ] - objss <- mapM getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', + let dirs = [ pref (ModuleName.toFilePath x ++ "_split") + | x <- libModules pkg_descr ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref dotToSep x <.> wanted_obj_ext + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext | x <- libModules pkg_descr ] @@ -603,11 +708,12 @@ ++ ["-i" ++ odir] ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] ++ ["-I" ++ odir] - ++ ["-I" ++ dir | dir <- includeDirs bi] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ ["-optP" ++ opt | opt <- cppOptions bi] - ++ ["-optc" ++ opt | opt <- ccOptions bi] - ++ [ "-#include \"" ++ inc ++ "\"" | inc <- includes bi ] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] ++ [ "-odir", odir, "-hidir", odir ] ++ (if compilerVersion c >= Version [6,8] [] then ["-stubdir", odir] else []) @@ -625,20 +731,23 @@ constructCcCmdLine lbi bi pref filename verbosity = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref | otherwise = pref takeDirectory filename - -- ghc 6.4.1 fixed a bug in -odir handling - -- for C compilations. - in + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in (odir, ghcCcOptions lbi bi odir ++ (if verbosity >= deafening then ["-v"] else []) ++ ["-c",filename]) - + ghcCcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] ghcCcOptions lbi bi odir - = ["-I" ++ dir | dir <- includeDirs bi] + = ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ (case withPackageDB lbi of + SpecificPackageDB db -> ["-package-conf", db] + _ -> []) ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] - ++ ["-optc" ++ opt | opt <- ccOptions bi] + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] ++ (case withOptimization lbi of NoOptimisation -> [] _ -> ["-optc-O2"]) @@ -661,7 +770,7 @@ let Just lib = library pkg_descr bi = libBuildInfo lib - + packageIdStr = display (packageId pkg_descr) (arProg, _) <- requireProgram verbosity arProgram AnyVersion (withPrograms lbi) @@ -669,60 +778,161 @@ (withPrograms lbi) let builddir = buildDir lbi Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) + Just ghcVersion = programVersion ghcProg let decls = [ - ("modules", unwords (exposedModules lib ++ otherModules bi)), + ("modules", unwords (map display (PD.exposedModules lib ++ otherModules bi))), ("GHC", programPath ghcProg), ("GHC_VERSION", (display (compilerVersion (compiler lbi)))), + ("VANILLA_WAY", if withVanillaLib lbi then "YES" else "NO"), ("WAYS", (if withProfLib lbi then "p " else "") ++ (if withSharedLib lbi then "dyn" else "")), ("odir", builddir), - ("srcdir", case hsSourceDirs bi of - [one] -> one - _ -> error "makefile: can't cope with multiple hs-source-dirs yet, sorry"), ("package", packageIdStr), - ("GHC_OPTS", unwords ( - ["-package-name", packageIdStr ] - ++ ghcOptions lbi bi (buildDir lbi))), + ("GHC_OPTS", unwords $ programArgs ghcProg + ++ ["-package-name", packageIdStr ] + ++ ghcOptions lbi bi (buildDir lbi)), ("MAKEFILE", file), ("C_SRCS", unwords (cSources bi)), ("GHC_CC_OPTS", unwords (ghcCcOptions lbi bi (buildDir lbi))), - ("GHCI_LIB", builddir mkGHCiLibName (packageId pkg_descr)), + ("GHCI_LIB", if withGHCiLib lbi + then builddir mkGHCiLibName (packageId pkg_descr) + else ""), ("soext", dllExtension), ("LIB_LD_OPTS", unwords (["-package-name", packageIdStr] - ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] - ++ ["-l"++libName | libName <- extraLibs bi] - ++ ["-L"++libDir | libDir <- extraLibDirs bi])), + ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] + ++ ["-l"++libName | libName <- extraLibs bi] + ++ ["-L"++libDir | libDir <- extraLibDirs bi])), ("AR", programPath arProg), - ("LD", programPath ldProg ++ concat [" " ++ arg | arg <- programArgs ldProg ]) + ("LD", programPath ldProg ++ concat [" " ++ arg | arg <- programArgs ldProg ]), + ("GENERATE_DOT_DEPEND", if ghcVersion >= Version [6,9] [] + then "-dep-makefile $(odir)/.depend" + else "-optdep-f -optdep$(odir)/.depend") ] + mkRules srcdir = [ + "$(odir_)%.$(osuf) : " ++ srcdir ++ "/%.hs", + "\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)", + "", + "$(odir_)%.$(osuf) : " ++ srcdir ++ "/%.lhs", + "\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)", + "", + "$(odir_)%.$(osuf) : " ++ srcdir ++ "/%.$(way_)s", + "\t@$(RM) $@", + "\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@", + "", + "$(odir_)%.$(osuf) : " ++ srcdir ++ "/%.S", + "\t@$(RM) $@", + "\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@", + "", + "$(odir_)%.$(osuf)-boot : " ++ srcdir ++ "/%.hs-boot", + "\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot", + "", + "$(odir_)%.$(osuf)-boot : " ++ srcdir ++ "/%.lhs-boot", + "\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot", + ""] + -- We used to do this with $(eval ...) and $(call ...) in the + -- Makefile, but make 3.79.1 (which is what comes with msys) + -- doesn't understand $(eval ...), so now we just stick the + -- expanded loop directly into the Makefile we generate. + vars = ["WAY_p_OPTS = -prof", + "WAY_dyn_OPTS = -fPIC -dynamic", + "WAY_dyn_CC_OPTS = -fPIC", + "", + "ifneq \"$(way)\" \"\"", + "way_ := $(way)_", + "_way := _$(way)", + "GHC_OPTS += $(WAY_$(way)_OPTS)", + "GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf)", + "GHC_CC_OPTS += $(WAY_$(way)_CC_OPTS)", + "endif", + "", + "osuf = $(way_)o", + "hisuf = $(way_)hi", + "", + "ifneq \"$(odir)\" \"\"", + "odir_ = $(odir)/", + "else", + "odir_ =", + "endif", + ""] + rules = concatMap mkRules (hsSourceDirs bi) + hPutStrLn h "# DO NOT EDIT! Automatically generated by Cabal\n" - hPutStrLn h (unlines (map (\(a,b)-> a ++ " = " ++ munge b) decls)) + hPutStrLn h $ unlines (map (\(a,b)-> a ++ " = " ++ munge b) decls) + hPutStrLn h $ unlines vars hPutStrLn h makefileTemplate + hPutStrLn h $ unlines rules + -- put the extra suffix rules *after* the suffix rules in the template. + -- the suffix rules in the tempate handle source files that have been + -- preprocessed and generated into distdir, whereas the suffix rules + -- here point to the source dir. We want the distdir to override the + -- source dir, just in case the user has left a preprocessed version + -- of a source file lying around in the source dir. Also this matches + -- the behaviour of 'cabal build'. hClose h where munge "" = "" munge ('#':s) = '\\':'#':munge s munge ('\\':s) = '/':munge s - -- for Windows, we want to use forward slashes in our pathnames in the Makefile + -- for Windows, we want to use forward slashes in our pathnames in the Makefile munge (c:s) = c : munge s -- ----------------------------------------------------------------------------- -- Installing -- |Install executables for GHC. -installExe :: Verbosity -- ^verbosity +installExe :: CopyFlags -- ^verbosity -> LocalBuildInfo - -> FilePath -- ^install location + -> InstallDirs FilePath -- ^Where to copy the files to + -> InstallDirs FilePath -- ^Where to pretend the files are (i.e. ignores --destdir) -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> IO () -installExe verbosity lbi pref buildPref (progprefix, progsuffix) pkg_descr - = do createDirectoryIfMissingVerbose verbosity True pref +installExe flags lbi installDirs pretendInstallDirs buildPref (progprefix, progsuffix) pkg_descr + = do let verbosity = fromFlag (copyVerbosity flags) + useWrapper = fromFlag (copyUseWrapper flags) + binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir withExe pkg_descr $ \Executable { exeName = e } -> do let exeFileName = e <.> exeExtension - fixedExeFileName = (progprefix ++ e ++ progsuffix) <.> exeExtension - copyFileVerbose verbosity (buildPref e exeFileName) (pref fixedExeFileName) - stripExe verbosity lbi exeFileName (pref fixedExeFileName) + exeDynFileName = e <.> "dyn" <.> exeExtension + fixedExeBaseName = progprefix ++ e ++ progsuffix + installBinary dest = do + copyFileVerbose verbosity + (buildPref e exeFileName) (dest <.> exeExtension) + exists <- doesFileExist (buildPref e exeDynFileName) + if exists then + copyFileVerbose verbosity + (buildPref e exeDynFileName) (dest <.> "dyn" <.> exeExtension) + else + return () + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + if useWrapper + then do + let libExecDir = libexecdir installDirs + pretendLibExecDir = libexecdir pretendInstallDirs + absExeFileName = + libExecDir fixedExeBaseName <.> exeExtension + pretendAbsExeFileName = + pretendLibExecDir fixedExeBaseName <.> exeExtension + wrapperFileName = binDir fixedExeBaseName + myPkgId = packageId (PD.package (localPkgDescr lbi)) + myCompilerId = compilerId (compiler lbi) + env = (ExecutableNameVar, + toPathTemplate pretendAbsExeFileName) + : fullPathTemplateEnv myPkgId myCompilerId + pretendInstallDirs + createDirectoryIfMissingVerbose verbosity True libExecDir + installBinary (libExecDir fixedExeBaseName) + -- XXX Should probably look somewhere more sensible + -- than just . for wrappers + wrapperTemplate <- readFile (e <.> "wrapper") + let wrapper = fromPathTemplate + $ substPathTemplate env + $ toPathTemplate wrapperTemplate + writeFileAtomic wrapperFileName wrapper + copyPermissions absExeFileName wrapperFileName + else do + installBinary (binDir fixedExeBaseName) stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $ @@ -742,29 +952,35 @@ _ -> [] -- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity -- ^verbosity +installLib :: CopyFlags -- ^verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic librarys -> FilePath -- ^Build location -> PackageDescription -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir - pkg@PackageDescription{library=Just lib} = do - -- copy .hi files over: - let copyModuleFiles ext = - smartCopySources verbosity [builtDir] targetDir (libModules pkg) [ext] - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" +installLib flags lbi targetDir dynlibTargetDir builtDir + pkg@PackageDescription{library=Just lib} = + unless (fromFlag $ copyInPlace flags) $ do + -- copy .hi files over: + let verbosity = fromFlag (copyVerbosity flags) + copy src dst n = copyFileVerbose verbosity (src n) (dst n) + copyModuleFiles ext = + smartCopySources verbosity [builtDir] targetDir + (libModules pkg) [ext] + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copy builtDir dynlibTargetDir sharedLibName + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copy builtDir dynlibTargetDir sharedLibName - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi (targetDir profileLibName) + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) where vanillaLibName = mkLibName pkgid @@ -773,7 +989,6 @@ sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) pkgid = packageId pkg - copy src dst n = copyFileVerbose verbosity (src n) (dst n) hasLib = not $ null (libModules pkg) && null (cSources (libBuildInfo lib)) diff --git a/Distribution/Simple/GHC/IPI641.hs b/Distribution/Simple/GHC/IPI641.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/IPI641.hs @@ -0,0 +1,121 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI641 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +{- 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 the University 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.Simple.GHC.IPI641 ( + InstalledPackageInfo, + toCurrent, + ) where + +import qualified Distribution.InstalledPackageInfo as Current + +import Distribution.Simple.GHC.IPI642 + ( PackageIdentifier, convertPackageId + , License, convertLicense, convertModuleName ) + +-- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.package = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + Current.hsLibraries = hsLibraries ipi, + Current.extraLibraries = extraLibraries ipi, + Current.extraGHCiLibraries = [], + Current.includeDirs = includeDirs ipi, + Current.includes = includes ipi, + Current.depends = map convertPackageId (depends ipi), + Current.hugsOptions = hugsOptions ipi, + Current.ccOptions = ccOptions ipi, + Current.ldOptions = ldOptions ipi, + Current.frameworkDirs = frameworkDirs ipi, + Current.frameworks = frameworks ipi, + Current.haddockInterfaces = haddockInterfaces ipi, + Current.haddockHTMLs = haddockHTMLs ipi + } diff --git a/Distribution/Simple/GHC/IPI642.hs b/Distribution/Simple/GHC/IPI642.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/IPI642.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI642 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +{- 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 the University 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.Simple.GHC.IPI642 ( + InstalledPackageInfo, + toCurrent, + + -- Don't use these, they're only for conversion purposes + PackageIdentifier, convertPackageId, + License, convertLicense, + convertModuleName + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import qualified Distribution.License as Current + +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Text (simpleParse) + +import Data.Maybe + +-- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.1 and before the format was slightly different. +-- See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +data PackageIdentifier = PackageIdentifier { + pkgName :: String, + pkgVersion :: Version + } + deriving Read + +data License = GPL | LGPL | BSD3 | BSD4 + | PublicDomain | AllRightsReserved | OtherLicense + deriving Read + +convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = + Current.PackageIdentifier (Current.PackageName n) v + +convertModuleName :: String -> ModuleName +convertModuleName s = fromJust $ simpleParse s + +convertLicense :: License -> Current.License +convertLicense GPL = Current.GPL +convertLicense LGPL = Current.LGPL +convertLicense BSD3 = Current.BSD3 +convertLicense BSD4 = Current.BSD4 +convertLicense PublicDomain = Current.PublicDomain +convertLicense AllRightsReserved = Current.AllRightsReserved +convertLicense OtherLicense = Current.OtherLicense + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.package = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + Current.hsLibraries = hsLibraries ipi, + Current.extraLibraries = extraLibraries ipi, + Current.extraGHCiLibraries = extraGHCiLibraries ipi, + Current.includeDirs = includeDirs ipi, + Current.includes = includes ipi, + Current.depends = map convertPackageId (depends ipi), + Current.hugsOptions = hugsOptions ipi, + Current.ccOptions = ccOptions ipi, + Current.ldOptions = ldOptions ipi, + Current.frameworkDirs = frameworkDirs ipi, + Current.frameworks = frameworks ipi, + Current.haddockInterfaces = haddockInterfaces ipi, + Current.haddockHTMLs = haddockHTMLs ipi + } diff --git a/Distribution/Simple/GHC/Makefile.hs b/Distribution/Simple/GHC/Makefile.hs --- a/Distribution/Simple/GHC/Makefile.hs +++ b/Distribution/Simple/GHC/Makefile.hs @@ -1,5 +1,5 @@ --- DO NOT EDIT: change Makefile.in, and run ../../../mkGHCMakefile.sh +-- DO NOT EDIT: change Makefile.in, and run ./mkGHCMakefile.sh module Distribution.Simple.GHC.Makefile where { makefileTemplate :: String; makefileTemplate=unlines -["# -----------------------------------------------------------------------------","# Makefile template starts here.","","GHC_OPTS += -i$(odir)","","# For adding options on the command-line","GHC_OPTS += $(EXTRA_HC_OPTS)","","WAY_p_OPTS = -prof","WAY_dyn_OPTS = -fPIC -dynamic","WAY_dyn_CC_OPTS = -fPIC","","ifneq \"$(way)\" \"\"","way_ := $(way)_","_way := _$(way)","GHC_OPTS += $(WAY_$(way)_OPTS)","GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf)","GHC_CC_OPTS += $(WAY_$(way)_CC_OPTS)","endif","osuf = $(way_)o","hisuf = $(way_)hi","","HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules)))","HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules)))","C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS))","","ifeq \"$(way:%dyn=YES)\" \"YES\"","LIB = $(odir)/libHS$(package)$(_way:%_dyn=%)-ghc$(GHC_VERSION)$(soext)","else","LIB = $(odir)/libHS$(package)$(_way).a","endif","","RM = rm -f","","# Optionally include local customizations:","-include Makefile.local","","# Rules follow:","","MKSTUBOBJS = find $(odir) -name \"*_stub.$(osuf)\" -print","# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to ","# make using cached directory contents, or something.","","all :: $(odir)/.depend $(LIB)","","$(odir)/.depend : $(MAKEFILE)","\t$(GHC) -M -optdep-f -optdep$(odir)/.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules)","\tfor dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \\","\t\tif test ! -d $$dir; then mkdir -p $$dir; fi \\","\tdone","","include $(odir)/.depend","","ifeq \"$(way:%dyn=YES)\" \"YES\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(GHC) -shared -dynamic -o $@ $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` $(LIB_LD_OPTS)","else","ifneq \"$(filter -split-objs, $(GHC_OPTS))\" \"\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t(echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs $(AR) q $(EXTRA_AR_ARGS) $@ ","else","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\techo $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` | xargs $(AR) q $(EXTRA_AR_ARGS) $@","endif","endif","","ifneq \"$(GHCI_LIB)\" \"\"","ifeq \"$(way)\" \"\"","all :: $(GHCI_LIB)","","$(GHCI_LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(LD) -r -o $@ $(EXTRA_LD_OPTS) $(HS_OBJS) `$(MKSTUBOBJS)` $(C_OBJS)","endif","endif","","# suffix rules","","ifneq \"$(odir)\" \"\"","odir_ = $(odir)/","else","odir_ =","endif","","$(odir_)%.$(osuf) : $(srcdir)/%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(srcdir)/%.lhs\t ","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","# The .hs files might be in $(odir) if they were preprocessed","$(odir_)%.$(osuf) : $(odir_)%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(odir_)%.lhs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(srcdir)/%.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(osuf) : $(srcdir)/%.$(way_)s","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(osuf) : $(srcdir)/%.S","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(way_)s : $(srcdir)/%.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -S $< -o $@","","$(odir_)%.$(osuf)-boot : $(srcdir)/%.hs-boot","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot","","$(odir_)%.$(osuf)-boot : $(srcdir)/%.lhs-boot","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot","","%.$(hisuf) : %.$(osuf)","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","%.$(way_)hi-boot : %.$(osuf)-boot","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","$(odir_)%.$(hisuf) : %.$(way_)hc","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","show:","\t@echo '$(VALUE)=\"$($(VALUE))\"'","","clean ::","\t$(RM) $(HS_OBJS) $(C_OBJS) $(LIB) $(GHCI_LIB) $(HS_IFS) .depend","\t$(RM) -rf $(wildcard $(patsubst %.$(osuf), %_split, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.o-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.hi-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %_stub.o, $(HS_OBJS)))","","ifneq \"$(strip $(WAYS))\" \"\"","ifeq \"$(way)\" \"\"","all clean ::","# Don't rely on -e working, instead we check exit return codes from sub-makes.","\t@case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \\","\tfor i in $(WAYS) ; do \\","\t echo \"== $(MAKE) way=$$i -f $(MAKEFILE) $@;\"; \\","\t $(MAKE) way=$$i -f $(MAKEFILE) --no-print-directory $(MFLAGS) $@ ; \\","\t if [ $$? -eq 0 ] ; then true; else exit $$x_on_err; fi; \\","\tdone","\t@echo \"== Finished recursively making \\`$@' for ways: $(WAYS) ...\"","endif","endif",""] +["# -----------------------------------------------------------------------------","# Makefile template starts here.","","default: all","","GHC_OPTS += -i$(odir)","","# For adding options on the command-line","GHC_OPTS += $(EXTRA_HC_OPTS)","","HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules)))","HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules)))","C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS))","","ifeq \"$(way:%dyn=YES)\" \"YES\"","LIB = $(odir)/libHS$(package)$(_way:%_dyn=%)-ghc$(GHC_VERSION)$(soext)","else","LIB = $(odir)/libHS$(package)$(_way).a","endif","","RM = rm -f","","# Optionally include local customizations:","-include Makefile.local","","# Rules follow:","","MKSTUBOBJS = find $(odir) -name \"*_stub.$(osuf)\" -print","# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to","# make using cached directory contents, or something.","","# We have to jump through some hoops if we don't want the vanilla way,","# as it's handled specially","ifneq \"$(way) $(VANILLA_WAY)\" \" NO\"","all :: $(odir)/.depend $(LIB)","endif","","$(odir)/.depend : $(MAKEFILE)","\t$(GHC) -M $(GENERATE_DOT_DEPEND) $(foreach way,$(WAYS),-dep-suffix-s -dep-suffix$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules)","\tfor dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \\","\t\tif test ! -d $$dir; then mkdir -p $$dir; fi \\","\tdone","","include $(odir)/.depend","","ifeq \"$(way:%dyn=YES)\" \"YES\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(GHC) -shared -dynamic -no-auto-link-packages -o $@ $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` $(LIB_LD_OPTS)","else","ifneq \"$(filter -split-objs, $(GHC_OPTS))\" \"\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t(echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs $(AR) q $(EXTRA_AR_ARGS) $@","else","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\techo $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` | xargs $(AR) q $(EXTRA_AR_ARGS) $@","endif","endif","","ifneq \"$(GHCI_LIB)\" \"\"","ifeq \"$(way)\" \"\"","all :: $(GHCI_LIB)","","$(GHCI_LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(LD) -r -o $@ $(EXTRA_LD_OPTS) $(HS_OBJS) `$(MKSTUBOBJS)` $(C_OBJS)","endif","endif","","# suffix rules","","# The .hs files might be in $(odir) if they were preprocessed","$(odir_)%.$(osuf) : $(odir_)%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(odir_)%.lhs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : %.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(way_)s : %.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -S $< -o $@","","%.$(hisuf) : %.$(osuf)","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","%.$(way_)hi-boot : %.$(osuf)-boot","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","$(odir_)%.$(hisuf) : %.$(way_)hc","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","show:","\t@echo '$(VALUE)=\"$($(VALUE))\"'","","clean ::","\t$(RM) $(HS_OBJS) $(C_OBJS) $(LIB) $(GHCI_LIB) $(HS_IFS) .depend","\t$(RM) -rf $(wildcard $(patsubst %.$(osuf), %_split, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.o-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.hi-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %_stub.o, $(HS_OBJS)))","","ifneq \"$(strip $(WAYS))\" \"\"","ifeq \"$(way)\" \"\"","all clean ::","# Don't rely on -e working, instead we check exit return codes from sub-makes.","\t@case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \\","\tfor i in $(WAYS) ; do \\","\t echo \"== $(MAKE) way=$$i -f $(MAKEFILE) $@;\"; \\","\t $(MAKE) way=$$i -f $(MAKEFILE) --no-print-directory $(MFLAGS) $@ ; \\","\t if [ $$? -eq 0 ] ; then true; else exit $$x_on_err; fi; \\","\tdone","\t@echo \"== Finished recursively making \\`$@' for ways: $(WAYS) ...\"","endif","endif",""] } diff --git a/Distribution/Simple/GHC/Makefile.in b/Distribution/Simple/GHC/Makefile.in --- a/Distribution/Simple/GHC/Makefile.in +++ b/Distribution/Simple/GHC/Makefile.in @@ -1,25 +1,13 @@ # ----------------------------------------------------------------------------- # Makefile template starts here. +default: all + GHC_OPTS += -i$(odir) # For adding options on the command-line GHC_OPTS += $(EXTRA_HC_OPTS) -WAY_p_OPTS = -prof -WAY_dyn_OPTS = -fPIC -dynamic -WAY_dyn_CC_OPTS = -fPIC - -ifneq "$(way)" "" -way_ := $(way)_ -_way := _$(way) -GHC_OPTS += $(WAY_$(way)_OPTS) -GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf) -GHC_CC_OPTS += $(WAY_$(way)_CC_OPTS) -endif -osuf = $(way_)o -hisuf = $(way_)hi - HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules))) HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules))) C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS)) @@ -38,13 +26,17 @@ # Rules follow: MKSTUBOBJS = find $(odir) -name "*_stub.$(osuf)" -print -# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to +# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to # make using cached directory contents, or something. +# We have to jump through some hoops if we don't want the vanilla way, +# as it's handled specially +ifneq "$(way) $(VANILLA_WAY)" " NO" all :: $(odir)/.depend $(LIB) +endif $(odir)/.depend : $(MAKEFILE) - $(GHC) -M -optdep-f -optdep$(odir)/.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules) + $(GHC) -M $(GENERATE_DOT_DEPEND) $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules) for dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \ if test ! -d $$dir; then mkdir -p $$dir; fi \ done @@ -54,12 +46,12 @@ ifeq "$(way:%dyn=YES)" "YES" $(LIB) : $(HS_OBJS) $(C_OBJS) @$(RM) $@ - $(GHC) -shared -dynamic -o $@ $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` $(LIB_LD_OPTS) + $(GHC) -shared -dynamic -no-auto-link-packages -o $@ $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` $(LIB_LD_OPTS) else ifneq "$(filter -split-objs, $(GHC_OPTS))" "" $(LIB) : $(HS_OBJS) $(C_OBJS) @$(RM) $@ - (echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs $(AR) q $(EXTRA_AR_ARGS) $@ + (echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs $(AR) q $(EXTRA_AR_ARGS) $@ else $(LIB) : $(HS_OBJS) $(C_OBJS) @$(RM) $@ @@ -79,18 +71,6 @@ # suffix rules -ifneq "$(odir)" "" -odir_ = $(odir)/ -else -odir_ = -endif - -$(odir_)%.$(osuf) : $(srcdir)/%.hs - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) - -$(odir_)%.$(osuf) : $(srcdir)/%.lhs - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) - # The .hs files might be in $(odir) if they were preprocessed $(odir_)%.$(osuf) : $(odir_)%.hs $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) @@ -98,27 +78,13 @@ $(odir_)%.$(osuf) : $(odir_)%.lhs $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) -$(odir_)%.$(osuf) : $(srcdir)/%.c - @$(RM) $@ - $(GHC) $(GHC_CC_OPTS) -c $< -o $@ - -$(odir_)%.$(osuf) : $(srcdir)/%.$(way_)s - @$(RM) $@ - $(GHC) $(GHC_CC_OPTS) -c $< -o $@ - -$(odir_)%.$(osuf) : $(srcdir)/%.S +$(odir_)%.$(osuf) : %.c @$(RM) $@ $(GHC) $(GHC_CC_OPTS) -c $< -o $@ -$(odir_)%.$(way_)s : $(srcdir)/%.c +$(odir_)%.$(way_)s : %.c @$(RM) $@ $(GHC) $(GHC_CC_OPTS) -S $< -o $@ - -$(odir_)%.$(osuf)-boot : $(srcdir)/%.hs-boot - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot - -$(odir_)%.$(osuf)-boot : $(srcdir)/%.lhs-boot - $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot %.$(hisuf) : %.$(osuf) @if [ ! -f $@ ] ; then \ diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -2,14 +2,19 @@ -- | -- Module : Distribution.Simple.Haddock -- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Invokes haddock to generate api documentation for libraries and optinally --- executables in this package. Also has support for generating --- syntax-highlighted source with HsColour and linking the haddock docs to it. +-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is +-- a rather complicated module. It deals with two versions of haddock (0.x and +-- 2.x). It has to do pre-processing for haddock 0.x which involves +-- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. It +-- uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating html versions of the original +-- source, with coloured syntax highlighting. {- All rights reserved. @@ -48,13 +53,14 @@ -- local import Distribution.Package ( PackageIdentifier, Package(..) ) +import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD (PackageDescription(..), BuildInfo(..), hcOptions, Library(..), hasLibs, withLib, Executable(..), withExe) import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..), compilerVersion - , extensionsToFlags ) + , extensionsToFlags ) import Distribution.Simple.Program ( ConfiguredProgram(..), requireProgram , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout @@ -70,7 +76,9 @@ initialPathTemplateEnv) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.BuildPaths ( haddockPref, haddockName, - hscolourPref, autogenModulesDir ) + hscolourPref, autogenModulesDir, + cppHeaderName ) +import Distribution.Simple.PackageIndex (dependencyClosure, allPackages) import qualified Distribution.Simple.PackageIndex as PackageIndex ( lookupPackageId ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -78,7 +86,7 @@ import Distribution.Simple.Utils ( die, warn, notice, intercalate, setupMessage , createDirectoryIfMissingVerbose, withTempFile - , findFileWithExtension, findFile, dotToSep ) + , findFileWithExtension, findFile ) import Distribution.Text ( display, simpleParse ) @@ -207,13 +215,14 @@ hPutStrLn prologFileHandle prolog hClose prologFileHandle let targets - | isVersion2 = modules + | isVersion2 = map display modules | otherwise = replaceLitExts inFiles let haddockFile = haddockPref distPref pkg_descr haddockName pkg_descr -- FIX: replace w/ rawSystemProgramConf? let hideArgs | fromFlag (haddockInternal flags) = [] - | otherwise = map ("--hide=" ++) (otherModules bi) + | otherwise = [ "--hide=" ++ display m + | m <- otherModules bi ] let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"] | otherwise = [] rawSystemProgram verbosity confHaddock @@ -226,7 +235,6 @@ ++ cssFileFlag ++ linkToHscolour ++ packageFlags - ++ programArgs confHaddock ++ verboseFlags ++ hideArgs ++ exportsFlags @@ -251,7 +259,7 @@ hPutStrLn prologFileHandle prolog hClose prologFileHandle let targets - | isVersion2 = srcMainPath : otherModules bi + | isVersion2 = srcMainPath : map display (otherModules bi) | otherwise = replaceLitExts inFiles let preprocessDir = buildDir lbi exeName exe exeName exe ++ "-tmp" let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"] @@ -263,7 +271,6 @@ , "--prologue=" ++ prologFileName ] ++ linkToHscolour ++ packageFlags - ++ programArgs confHaddock ++ verboseFlags ++ exportsFlags ++ haddock2options bi preprocessDir @@ -300,6 +307,11 @@ -> Maybe PathTemplate -> IO ([String], Maybe String) haddockPackageFlags lbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = packageDeps lbi + transitiveDeps <- case dependencyClosure allPkgs directDeps of + Left x -> return x + Right _ -> die "Can't find transitive deps for haddock" interfaces <- sequence [ case interfaceAndHtmlPath pkgid of Nothing -> return (pkgid, Nothing) @@ -308,7 +320,7 @@ if exists then return (pkgid, Just (interface, html)) else return (pkgid, Nothing) - | pkgid <- packageDeps lbi ] + | pkgid <- map InstalledPackageInfo.package $ allPackages transitiveDeps ] let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] warning = "The documentation for the following packages are not " @@ -345,6 +357,8 @@ ++ ["-i" ++ autogenModulesDir lbi] ++ ["-i" ++ mockDir] ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] ++ ["-odir", mockDir] ++ ["-hidir", mockDir] ++ extensionsToFlags c (extensions bi) @@ -365,29 +379,30 @@ preprocessSources pkg_descr lbi False verbosity suffixes setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - let replaceDot = map (\c -> if c == '.' then '-' else c) + let moduleNameToHtmlFilePath mn = + intercalate "-" (ModuleName.components mn) <.> "html" withLib pkg_descr () $ \lib -> when (isJust $ library pkg_descr) $ do let bi = libBuildInfo lib modules = PD.exposedModules lib ++ otherModules bi - outputDir = hscolourPref distPref pkg_descr "src" - createDirectoryIfMissingVerbose verbosity True outputDir - copyCSS hscolourProg outputDir + outputDir = hscolourPref distPref pkg_descr "src" + createDirectoryIfMissingVerbose verbosity True outputDir + copyCSS hscolourProg outputDir inFiles <- getLibSourceFiles lbi lib flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> - let outFile = outputDir replaceDot mo <.> "html" + let outFile = outputDir moduleNameToHtmlFilePath mo in rawSystemProgram verbosity hscolourProg ["-css", "-anchor", "-o" ++ outFile, inFile] withExe pkg_descr $ \exe -> when doExes $ do let bi = buildInfo exe - modules = "Main" : otherModules bi + modules = ModuleName.main : otherModules bi outputDir = hscolourPref distPref pkg_descr exeName exe "src" createDirectoryIfMissingVerbose verbosity True outputDir copyCSS hscolourProg outputDir inFiles <- getExeSourceFiles lbi exe flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> - let outFile = outputDir replaceDot mo <.> "html" + let outFile = outputDir moduleNameToHtmlFilePath mo in rawSystemProgram verbosity hscolourProg ["-css", "-anchor", "-o" ++ outFile, inFile] @@ -405,24 +420,24 @@ getLibSourceFiles :: LocalBuildInfo -> Library -> IO [FilePath] getLibSourceFiles lbi lib = sequence [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi) - (dotToSep module_) >>= maybe (notFound module_) (return . normalise) + (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise) | module_ <- modules ] where bi = libBuildInfo lib modules = PD.exposedModules lib ++ otherModules bi preprocessDir = buildDir lbi - notFound module_ = die $ "can't find source for module " ++ module_ + notFound module_ = die $ "can't find source for module " ++ display module_ getExeSourceFiles :: LocalBuildInfo -> Executable -> IO [FilePath] getExeSourceFiles lbi exe = do srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) moduleFiles <- sequence [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi) - (dotToSep module_) >>= maybe (notFound module_) (return . normalise) + (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise) | module_ <- modules ] return (srcMainPath : moduleFiles) where bi = buildInfo exe modules = otherModules bi preprocessDir = buildDir lbi exeName exe exeName exe ++ "-tmp" - notFound module_ = die $ "can't find source for module " ++ module_ + notFound module_ = die $ "can't find source for module " ++ display module_ diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -2,12 +2,12 @@ -- | -- Module : Distribution.Simple.Hugs -- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Build and install functionality for Hugs. +-- This module contains most of the NHC-specific code for configuring, building +-- and installing packages. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -41,47 +41,51 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Hugs ( - configure, build, install + configure, build, install ) where import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), hcOptions, Executable(..), withExe, Library(..), withLib, libModules ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag ) import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, requireProgram, rawSystemProgramConf, ffihugsProgram, hugsProgram ) -import Distribution.Version ( Version(..), VersionRange(AnyVersion) ) -import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) +import Distribution.Version ( Version(..), VersionRange(AnyVersion) ) +import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) import Distribution.Simple.PreProcess.Unlit - ( unlit ) + ( unlit ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..)) + ( LocalBuildInfo(..)) import Distribution.Simple.BuildPaths ( autogenModuleName, autogenModulesDir, dllExtension ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, readUTF8File - , findFile, dotToSep, findFileWithExtension, smartCopySources + ( createDirectoryIfMissingVerbose + , withUTF8FileContents, writeFileAtomic + , findFile, findFileWithExtension, smartCopySources , die, info, notice ) import Language.Haskell.Extension - ( Extension(..) ) -import System.FilePath ( (), takeExtension, (<.>), + ( Extension(..) ) +import System.FilePath ( (), takeExtension, (<.>), searchPathSeparator, normalise, takeDirectory ) import Distribution.System ( OS(..), buildOS ) +import Distribution.Text + ( display ) import Distribution.Verbosity -import Data.Char ( isSpace ) -import Data.Maybe ( mapMaybe, catMaybes ) -import Control.Monad ( unless, when, filterM ) -import Control.Exception ( try ) -import Data.List ( nub, sort, isSuffixOf ) -import System.Directory ( Permissions(..), getPermissions, - setPermissions, copyFile, - removeDirectoryRecursive ) - +import Data.Char ( isSpace ) +import Data.Maybe ( mapMaybe, catMaybes ) +import Control.Monad ( unless, when, filterM ) +import Data.List ( nub, sort, isSuffixOf ) +import System.Directory ( Permissions(..), getPermissions, + setPermissions, copyFile, + removeDirectoryRecursive ) +import Distribution.Compat.Exception -- ----------------------------------------------------------------------------- -- Configuring @@ -134,78 +138,79 @@ let pref = scratchDir lbi createDirectoryIfMissingVerbose verbosity True pref withLib pkg_descr () $ \ l -> do - copyFile (autogenModulesDir lbi paths_modulename) - (pref paths_modulename) - compileBuildInfo pref [] (libModules pkg_descr) (libBuildInfo l) + copyFile (autogenModulesDir lbi paths_modulename) + (pref paths_modulename) + compileBuildInfo pref [] (libModules pkg_descr) (libBuildInfo l) withExe pkg_descr $ compileExecutable (pref "programs") where - srcDir = buildDir lbi + srcDir = buildDir lbi - paths_modulename = autogenModuleName pkg_descr ++ ".hs" + paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) + <.> ".hs" - compileExecutable :: FilePath -> Executable -> IO () - compileExecutable destDir (exe@Executable {modulePath=mainPath, buildInfo=bi}) = do + compileExecutable :: FilePath -> Executable -> IO () + compileExecutable destDir (exe@Executable {modulePath=mainPath, buildInfo=bi}) = do let exeMods = otherModules bi - srcMainFile <- findFile (hsSourceDirs bi) mainPath - let exeDir = destDir exeName exe - let destMainFile = exeDir hugsMainFilename exe - copyModule (CPP `elem` extensions bi) bi srcMainFile destMainFile - let destPathsFile = exeDir paths_modulename - copyFile (autogenModulesDir lbi paths_modulename) - destPathsFile - compileBuildInfo exeDir (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi - compileFiles bi exeDir [destMainFile, destPathsFile] - - compileBuildInfo :: FilePath -- ^output directory + srcMainFile <- findFile (hsSourceDirs bi) mainPath + let exeDir = destDir exeName exe + let destMainFile = exeDir hugsMainFilename exe + copyModule (CPP `elem` extensions bi) bi srcMainFile destMainFile + let destPathsFile = exeDir paths_modulename + copyFile (autogenModulesDir lbi paths_modulename) + destPathsFile + compileBuildInfo exeDir (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi + compileFiles bi exeDir [destMainFile, destPathsFile] + + compileBuildInfo :: FilePath -- ^output directory -> [FilePath] -- ^library source dirs, if building exes - -> [String] -- ^Modules + -> [ModuleName] -- ^Modules -> BuildInfo -> IO () - compileBuildInfo destDir mLibSrcDirs mods bi = do - -- Pass 1: copy or cpp files from build directory to scratch directory - let useCpp = CPP `elem` extensions bi - let srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs + compileBuildInfo destDir mLibSrcDirs mods bi = do + -- Pass 1: copy or cpp files from build directory to scratch directory + let useCpp = CPP `elem` extensions bi + let srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs info verbosity $ "Source directories: " ++ show srcDirs flip mapM_ mods $ \ m -> do - fs <- findFileWithExtension suffixes srcDirs (dotToSep m) + fs <- findFileWithExtension suffixes srcDirs (ModuleName.toFilePath m) case fs of Nothing -> - die ("can't find source for module " ++ m) + die ("can't find source for module " ++ display m) Just srcFile -> do let ext = takeExtension srcFile copyModule useCpp bi srcFile - (destDir dotToSep m <.> ext) - -- Pass 2: compile foreign stubs in scratch directory - stubsFileLists <- fmap catMaybes $ sequence - [ findFileWithExtension suffixes [destDir] (dotToSep modu) + (destDir ModuleName.toFilePath m <.> ext) + -- Pass 2: compile foreign stubs in scratch directory + stubsFileLists <- fmap catMaybes $ sequence + [ findFileWithExtension suffixes [destDir] (ModuleName.toFilePath modu) | modu <- mods] compileFiles bi destDir stubsFileLists - suffixes = ["hs", "lhs"] + suffixes = ["hs", "lhs"] - -- Copy or cpp a file from the source directory to the build directory. - copyModule :: Bool -> BuildInfo -> FilePath -> FilePath -> IO () - copyModule cppAll bi srcFile destFile = do - createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) - (exts, opts, _) <- getOptionsFromSource srcFile - let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] - if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do - runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity - return () - else - copyFile srcFile destFile + -- Copy or cpp a file from the source directory to the build directory. + copyModule :: Bool -> BuildInfo -> FilePath -> FilePath -> IO () + copyModule cppAll bi srcFile destFile = do + createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) + (exts, opts, _) <- getOptionsFromSource srcFile + let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] + if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do + runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity + return () + else + copyFile srcFile destFile compileFiles :: BuildInfo -> FilePath -> [FilePath] -> IO () compileFiles bi modDir fileList = do - ffiFileList <- filterM testFFI fileList + ffiFileList <- filterM testFFI fileList unless (null ffiFileList) $ do notice verbosity "Compiling FFI stubs" mapM_ (compileFFI bi modDir) ffiFileList -- Only compile FFI stubs for a file if it contains some FFI stuff testFFI :: FilePath -> IO Bool - testFFI file = do - inp <- readHaskellFile file - return ("foreign" `elem` symbols (stripComments False inp)) + testFFI file = + withHaskellFile file $ \inp -> + return $! "foreign" `elem` symbols (stripComments False inp) compileFFI :: BuildInfo -> FilePath -> FilePath -> IO () compileFFI bi modDir file = do @@ -225,36 +230,39 @@ ["-l" ++ lib | lib <- extraLibs bi] ++ concat [["-framework", f] | f <- frameworks bi] rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi) - (hugsArgs ++ file : cArgs) + (hugsArgs ++ file : cArgs) - includeOpts :: [String] -> [String] - includeOpts [] = [] - includeOpts ("-#include" : arg : opts) = arg : includeOpts opts - includeOpts (_ : opts) = includeOpts opts + includeOpts :: [String] -> [String] + includeOpts [] = [] + includeOpts ("-#include" : arg : opts) = arg : includeOpts opts + includeOpts (_ : opts) = includeOpts opts - -- get C file names from CFILES pragmas throughout the source file - getCFiles :: FilePath -> IO [String] - getCFiles file = do - inp <- readHaskellFile file - return [normalise cfile | - "{-#" : "CFILES" : rest <- - map words $ lines $ stripComments True inp, - last rest == "#-}", - cfile <- init rest] + -- get C file names from CFILES pragmas throughout the source file + getCFiles :: FilePath -> IO [String] + getCFiles file = + withHaskellFile file $ \inp -> + let cfiles = + [ normalise cfile + | "{-#" : "CFILES" : rest <- map words + $ lines + $ stripComments True inp + , last rest == "#-}" + , cfile <- init rest] + in seq (length cfiles) (return cfiles) - -- List of terminal symbols in a source file. - symbols :: String -> [String] - symbols cs = case lex cs of - (sym, cs'):_ | not (null sym) -> sym : symbols cs' - _ -> [] + -- List of terminal symbols in a source file. + symbols :: String -> [String] + symbols cs = case lex cs of + (sym, cs'):_ | not (null sym) -> sym : symbols cs' + _ -> [] - -- Get the non-literate source of a Haskell module. - readHaskellFile :: FilePath -> IO String - readHaskellFile file = do - text <- readUTF8File file - if ".lhs" `isSuffixOf` file - then either return die (unlit file text) - else return text +-- Get the non-literate source of a Haskell module. +withHaskellFile :: FilePath -> (String -> IO a) -> IO a +withHaskellFile file action = + withUTF8FileContents file $ \text -> + if ".lhs" `isSuffixOf` file + then either action die (unlit file text) + else action text -- ------------------------------------------------------------ -- * options in source files @@ -268,38 +276,37 @@ [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas [String] -- INCLUDE pragmas ) -getOptionsFromSource file = do - text <- readUTF8File file - text' <- if ".lhs" `isSuffixOf` file - then either return die (unlit file text) - else return text - return $ foldr appendOptions ([],[],[]) $ map getOptions $ - takeWhileJust $ map getPragma $ - filter textLine $ map (dropWhile isSpace) $ lines $ - stripComments True text' +getOptionsFromSource file = + withHaskellFile file $ + (return $!) + . foldr appendOptions ([],[],[]) . map getOptions + . takeWhileJust . map getPragma + . filter textLine . map (dropWhile isSpace) . lines + . stripComments True + where textLine [] = False - textLine ('#':_) = False - textLine _ = True + textLine ('#':_) = False + textLine _ = True - getPragma :: String -> Maybe [String] - getPragma line = case words line of - ("{-#" : rest) | last rest == "#-}" -> Just (init rest) - _ -> Nothing + getPragma :: String -> Maybe [String] + getPragma line = case words line of + ("{-#" : rest) | last rest == "#-}" -> Just (init rest) + _ -> Nothing - getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], []) - getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], []) - getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], []) - getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], []) - getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], []) - where readExtension :: String -> Maybe Extension - readExtension w = case reads w of - [(ext, "")] -> Just ext - [(ext, ",")] -> Just ext - _ -> Nothing - getOptions ("INCLUDE":ws) = ([], [], ws) - getOptions _ = ([], [], []) + getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], []) + getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], []) + getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], []) + getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], []) + getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], []) + where readExtension :: String -> Maybe Extension + readExtension w = case reads w of + [(ext, "")] -> Just ext + [(ext, ",")] -> Just ext + _ -> Nothing + getOptions ("INCLUDE":ws) = ([], [], ws) + getOptions _ = ([], [], []) - appendOptions (exts, opts, incs) (exts', opts', incs') + appendOptions (exts, opts, incs) (exts', opts', incs') = (exts++exts', opts++opts', incs++incs') -- takeWhileJust f = map fromJust . takeWhile isJust @@ -309,30 +316,30 @@ -- |Strip comments from Haskell source. stripComments - :: Bool -- ^ preserve pragmas? - -> String -- ^ input source text + :: Bool -- ^ preserve pragmas? + -> String -- ^ input source text -> String stripComments keepPragmas = stripCommentsLevel 0 where stripCommentsLevel :: Int -> String -> String - stripCommentsLevel 0 ('"':cs) = '"':copyString cs - stripCommentsLevel 0 ('-':'-':cs) = -- FIX: symbols like --> - stripCommentsLevel 0 (dropWhile (/= '\n') cs) - stripCommentsLevel 0 ('{':'-':'#':cs) - | keepPragmas = '{' : '-' : '#' : copyPragma cs - stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs - stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs - stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs - stripCommentsLevel n (_:cs) = stripCommentsLevel n cs - stripCommentsLevel _ [] = [] + stripCommentsLevel 0 ('"':cs) = '"':copyString cs + stripCommentsLevel 0 ('-':'-':cs) = -- FIX: symbols like --> + stripCommentsLevel 0 (dropWhile (/= '\n') cs) + stripCommentsLevel 0 ('{':'-':'#':cs) + | keepPragmas = '{' : '-' : '#' : copyPragma cs + stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs + stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs + stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs + stripCommentsLevel n (_:cs) = stripCommentsLevel n cs + stripCommentsLevel _ [] = [] - copyString ('\\':c:cs) = '\\' : c : copyString cs - copyString ('"':cs) = '"' : stripCommentsLevel 0 cs - copyString (c:cs) = c : copyString cs - copyString [] = [] + copyString ('\\':c:cs) = '\\' : c : copyString cs + copyString ('"':cs) = '"' : stripCommentsLevel 0 cs + copyString (c:cs) = c : copyString cs + copyString [] = [] - copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs - copyPragma (c:cs) = c : copyPragma cs - copyPragma [] = [] + copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs + copyPragma (c:cs) = c : copyPragma cs + copyPragma [] = [] -- ----------------------------------------------------------------------------- -- |Install for Hugs. @@ -354,7 +361,7 @@ -> PackageDescription -> IO () install verbosity libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do - try $ removeDirectoryRecursive libDir + removeDirectoryRecursive libDir `catchIO` \_ -> return () smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes let buildProgDir = buildPref "programs" when (any (buildable . buildInfo) (executables pkg_descr)) $ @@ -363,9 +370,11 @@ let theBuildDir = buildProgDir exeName exe let installDir = installProgDir exeName exe let targetDir = targetProgDir exeName exe - try $ removeDirectoryRecursive installDir + removeDirectoryRecursive installDir `catchIO` \_ -> return () smartCopySources verbosity [theBuildDir] installDir - ("Main" : autogenModuleName pkg_descr : otherModules (buildInfo exe)) hugsInstallSuffixes + (ModuleName.main : autogenModuleName pkg_descr + : otherModules (buildInfo exe)) + hugsInstallSuffixes let targetName = "\"" ++ (targetDir hugsMainFilename exe) ++ "\"" -- FIX (HUGS): use extensions, and options from file too? -- see http://hackage.haskell.org/trac/hackage/ticket/43 @@ -383,7 +392,7 @@ let args = hugsOptions ++ [targetName, "\"$@\""] in unlines ["#! /bin/sh", unwords ("runhugs" : args)] - writeFile exeFile script + writeFileAtomic exeFile script perms <- getPermissions exeFile setPermissions exeFile perms { executable = True, readable = True } diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -2,14 +2,14 @@ -- | -- Module : Distribution.Simple.Install -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Perform the \"@.\/setup install@\" and \"@.\/setup --- copy@\" actions. Move files into place based on the prefix --- argument. +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- place based on the prefix argument. It does the generic bits and then calls +-- compiler-specific functions to do the rest. {- All rights reserved. @@ -42,20 +42,20 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Install ( - install, + install, ) where import Distribution.PackageDescription ( - PackageDescription(..), BuildInfo(..), Library(..), - hasLibs, withLib, hasExes, withExe ) + PackageDescription(..), BuildInfo(..), Library(..), + hasLibs, withLib, hasExes, withExe ) import Distribution.Package (Package(..)) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, substPathTemplate) import Distribution.Simple.BuildPaths (haddockName, haddockPref) -import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, - copyFileVerbose, die, info, notice, - copyDirectoryRecursiveVerbose) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, copyDirectoryRecursiveVerbose + , copyFileVerbose, die, info, notice, matchDirFileGlob ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag) @@ -66,7 +66,8 @@ import qualified Distribution.Simple.Hugs as Hugs import Control.Monad (when, unless) -import System.Directory (doesDirectoryExist, doesFileExist) +import System.Directory (doesDirectoryExist, doesFileExist, + getCurrentDirectory) import System.FilePath ( takeFileName, takeDirectory, (), isAbsolute ) @@ -81,10 +82,18 @@ -> CopyFlags -- ^flags sent to copy or install -> IO () install pkg_descr lbi flags = do + thisDir <- getCurrentDirectory let distPref = fromFlag (copyDistPref flags) verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest' flags) - InstallDirs { + inPlace = fromFlag (copyInPlace flags) + copydest = fromFlag (copyDest flags) + copyTo = if inPlace + then CopyTo (thisDir distPref "install") + else copydest + pretendCopyTo = if inPlace + then copyTo + else NoCopyDest + installDirs@(InstallDirs { bindir = binPref, libdir = libPref, dynlibdir = dynlibPref, @@ -93,19 +102,24 @@ docdir = docPref, htmldir = htmlPref, haddockdir = interfacePref, - includedir = incPref - } = absoluteInstallDirs pkg_descr lbi copydest - + includedir = incPref}) + = absoluteInstallDirs pkg_descr lbi copyTo + pretendInstallDirs = absoluteInstallDirs pkg_descr lbi pretendCopyTo + progPrefixPref = substPathTemplate pkg_descr lbi (progPrefix lbi) progSuffixPref = substPathTemplate pkg_descr lbi (progSuffix lbi) - + docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ " does exist: " ++ show docExists) flip mapM_ (dataFiles pkg_descr) $ \ file -> do + let srcDataDir = dataDir pkg_descr + files <- matchDirFileGlob srcDataDir file let dir = takeDirectory file createDirectoryIfMissingVerbose verbosity True (dataPref dir) - copyFileVerbose verbosity (dataDir pkg_descr file) (dataPref file) + sequence_ [ copyFileVerbose verbosity (srcDataDir file') + (dataPref file') + | file' <- files ] when docExists $ do createDirectoryIfMissingVerbose verbosity True htmlPref copyDirectoryRecursiveVerbose verbosity @@ -133,9 +147,9 @@ let buildPref = buildDir lbi when (hasLibs pkg_descr) $ - notice verbosity ("Installing: " ++ libPref) + notice verbosity ("Installing library in " ++ libPref) when (hasExes pkg_descr) $ - notice verbosity ("Installing: " ++ binPref) + notice verbosity ("Installing executable(s) in " ++ binPref) -- install include files for all compilers - they may be needed to compile -- haskell files (using the CPP extension) @@ -143,9 +157,9 @@ case compilerFlavor (compiler lbi) of GHC -> do withLib pkg_descr () $ \_ -> - GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + GHC.installLib flags lbi libPref dynlibPref buildPref pkg_descr withExe pkg_descr $ \_ -> - GHC.installExe verbosity lbi binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr + GHC.installExe flags lbi installDirs pretendInstallDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr JHC -> do withLib pkg_descr () $ JHC.installLib verbosity libPref buildPref pkg_descr withExe pkg_descr $ JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr Hugs -> do @@ -166,7 +180,7 @@ unless (null incs) $ do createDirectoryIfMissingVerbose verbosity True incdir sequence_ [ copyFileVerbose verbosity path (incdir f) - | (f,path) <- incs ] + | (f,path) <- incs ] where relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) lbi = libBuildInfo l diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -9,15 +9,17 @@ -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 -- --- Maintainer : Isaac Jones --- Stability : alpha +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Definition of the 'LocalBuildInfo' data type. This is basically --- the information that is gathered by the end of the configuration --- step which could include package information from ghc-pkg, flags --- the user passed to configure, and the location of tools in the --- PATH. +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- provides a 'PathTemplate' type and functions for substituting for these +-- templates. {- All rights reserved. @@ -64,6 +66,7 @@ fromPathTemplate, substPathTemplate, initialPathTemplateEnv, + fullPathTemplateEnv, ) where @@ -79,7 +82,7 @@ import Distribution.Package ( PackageIdentifier, packageName, packageVersion ) import Distribution.System - ( OS(..), buildOS ) + ( OS(..), buildOS, buildArch ) import Distribution.Compiler ( CompilerId, CompilerFlavor(..) ) import Distribution.Text @@ -105,15 +108,15 @@ prefix :: dir, bindir :: dir, libdir :: dir, - libsubdir :: dir, + libsubdir :: dir, dynlibdir :: dir, libexecdir :: dir, progdir :: dir, includedir :: dir, datadir :: dir, - datasubdir :: dir, + datasubdir :: dir, docdir :: dir, - mandir :: dir, + mandir :: dir, htmldir :: dir, haddockdir :: dir } deriving (Read, Show) @@ -157,8 +160,8 @@ combineInstallDirs :: (a -> b -> c) -> InstallDirs a - -> InstallDirs b - -> InstallDirs c + -> InstallDirs b + -> InstallDirs c combineInstallDirs combine a b = InstallDirs { prefix = prefix a `combine` prefix b, bindir = bindir a `combine` bindir b, @@ -184,7 +187,7 @@ datasubdir = error "internal error InstallDirs.datasubdir" } --- | The installation dirctories in terms of 'PathTemplate's that contain +-- | The installation directories in terms of 'PathTemplate's that contain -- variables. -- -- The defaults for most of the directories are relative to each other, in @@ -196,10 +199,10 @@ -- -- A few of these installation directories are split into two components, the -- dir and subdir. The full installation path is formed by combining the two --- together with @\/@. The reason for this is compatability with other unix +-- together with @\/@. The reason for this is compatibility with other unix -- build systems which also support @--libdir@ and @--datadir@. We would like -- users to be able to configure @--libdir=\/usr\/lib64@ for example but --- because by default we want to support installing multiplve versions of +-- because by default we want to support installing multiple versions of -- packages and building the same package for multiple compilers we append the -- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@. -- @@ -242,7 +245,7 @@ datasubdir = "$pkgid", docdir = case buildOS of Windows -> "$prefix" "doc" "$pkgid" - _other -> "$datadir" "doc" "$pkgid", + _other -> "$datadir" "doc" "$pkgid", mandir = "$datadir" "man", htmldir = "$docdir" "html", haddockdir = "$htmldir" @@ -314,7 +317,7 @@ $ substituteTemplates pkgId compilerId dirs { prefix = case copydest of -- possibly override the prefix - CopyPrefix p -> toPathTemplate p + CopyPrefix p -> toPathTemplate p _ -> prefix dirs } @@ -378,6 +381,9 @@ | PkgVerVar -- ^ The @$version@ package version path variable | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ + | OSVar -- ^ The operating system name, eg @windows@ or @linux@ + | ArchVar -- ^ The cpu architecture name, eg @i386@ or @x86_64@ + | ExecutableNameVar -- ^ The executable name; used in shell wrappers deriving Eq -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. @@ -410,11 +416,34 @@ -> [(PathTemplateVariable, PathTemplate)] initialPathTemplateEnv pkgId compilerId = map (\(v,s) -> (v, PathTemplate [Ordinary s])) - [(PkgNameVar, packageName pkgId) + [(PkgNameVar, display (packageName pkgId)) ,(PkgVerVar, display (packageVersion pkgId)) ,(PkgIdVar, display pkgId) - ,(CompilerVar, display compilerId)] + ,(CompilerVar, display compilerId) + ,(OSVar, display buildOS) --these should be params if we want to be + ,(ArchVar, display buildArch) --able to do cross-platform configuation + ] +fullPathTemplateEnv :: PackageIdentifier -> CompilerId + -> InstallDirs FilePath + -> [(PathTemplateVariable, PathTemplate)] +fullPathTemplateEnv pkgId compilerId dirs = env ++ dirEnv + where -- The initial environment has all the static stuff but no paths + env = initialPathTemplateEnv pkgId compilerId + -- And here are all the paths + dirEnv = [(PrefixVar, toPathTemplate $ prefix dirs), + (BindirVar, toPathTemplate $ bindir dirs), + (LibdirVar, toPathTemplate $ libdir dirs), + -- This isn't defined in an InstallDirs FilePath + -- as its value has already been appended to libdir: + -- (LibsubdirVar, toPathTemplate $ libsubdir dirs), + (DatadirVar, toPathTemplate $ datadir dirs), + -- This isn't defined in an InstallDirs FilePath + -- as its value has already been appended to datadir: + -- (DatasubdirVar, toPathTemplate $ datasubdir dirs), + (DocdirVar, toPathTemplate $ docdir dirs), + (HtmldirVar, toPathTemplate $ htmldir dirs)] + -- --------------------------------------------------------------------------- -- Parsing and showing path templates: @@ -437,6 +466,9 @@ show PkgVerVar = "version" show PkgIdVar = "pkgid" show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show ExecutableNameVar = "executablename" instance Read PathTemplateVariable where readsPrec _ s = @@ -445,17 +477,20 @@ | (varStr, var) <- vars , varStr `isPrefixOf` s ] where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar)] + ,("bindir", BindirVar) + ,("libdir", LibdirVar) + ,("libsubdir", LibsubdirVar) + ,("datadir", DatadirVar) + ,("datasubdir", DatasubdirVar) + ,("docdir", DocdirVar) + ,("htmldir", HtmldirVar) + ,("pkgid", PkgIdVar) + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar) + ,("os", OSVar) + ,("arch", ArchVar) + ,("executablename", ExecutableNameVar)] instance Show PathComponent where show (Ordinary path) = path @@ -469,8 +504,8 @@ lex0 ('$':'$':s') = lex0 ('$':s') lex0 ('$':s') = case [ (Variable var, s'') | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok + [] -> lex1 "$" s' + ok -> ok lex0 s' = lex1 [] s' lex1 "" "" = [] lex1 acc "" = [(Ordinary (reverse acc), "")] @@ -511,8 +546,8 @@ allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath if (r /= 0) - then return Nothing - else do s <- peekCString pPath; return (Just s) + then return Nothing + else do s <- peekCString pPath; return (Just s) where long_path_size = 1024 # endif diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs --- a/Distribution/Simple/JHC.hs +++ b/Distribution/Simple/JHC.hs @@ -2,12 +2,12 @@ -- | -- Module : Distribution.Simple.JHC -- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Build and install functionality for the JHC compiler. +-- This module contains most of the JHC-specific code for configuring, building +-- and installing packages. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -41,24 +41,24 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.JHC ( - configure, getInstalledPackages, build, installLib, installExe + configure, getInstalledPackages, build, installLib, installExe ) where import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), - withLib, - Executable(..), withExe, Library(..), - libModules, hcOptions ) + ( PackageDescription(..), BuildInfo(..), + withLib, + Executable(..), withExe, Library(..), + libModules, hcOptions ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, emptyInstalledPackageInfo ) + ( InstalledPackageInfo, emptyInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(package) ) + ( InstalledPackageInfo_(package) ) import Distribution.Simple.PackageIndex (PackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) ) + ( LocalBuildInfo(..) ) import Distribution.Simple.BuildPaths - ( autogenModulesDir, exeExtension ) + ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..) , PackageDB, Flag, extensionsToFlags ) @@ -67,11 +67,11 @@ ProgramConfiguration, userMaybeSpecifyPath, requireProgram, lookupProgram, rawSystemProgram, rawSystemProgramStdoutConf ) -import Distribution.Version ( VersionRange(AnyVersion) ) +import Distribution.Version ( VersionRange(AnyVersion) ) import Distribution.Package ( Package(..) ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, copyFileVerbose + ( createDirectoryIfMissingVerbose, copyFileVerbose, writeFileAtomic , die, info, intercalate ) import System.FilePath ( () ) import Distribution.Verbosity @@ -80,8 +80,8 @@ import Distribution.Compat.ReadP ( readP_to_S, many, skipSpaces ) -import Data.List ( nub ) -import Data.Char ( isSpace ) +import Data.List ( nub ) +import Data.Char ( isSpace ) @@ -138,11 +138,12 @@ info verbosity "Building library..." let libBi = libBuildInfo lib let args = constructJHCCmdLine lbi libBi (buildDir lbi) verbosity - rawSystemProgram verbosity jhcProg (["-c"] ++ args ++ libModules pkg_descr) + rawSystemProgram verbosity jhcProg $ + ["-c"] ++ args ++ map display (libModules pkg_descr) let pkgid = display (packageId pkg_descr) pfile = buildDir lbi "jhc-pkg.conf" hlfile= buildDir lbi (pkgid ++ ".hl") - writeFile pfile $ jhcPkgConf pkg_descr + writeFileAtomic pfile $ jhcPkgConf pkg_descr rawSystemProgram verbosity jhcProg ["--build-hl="++pfile, "-o", hlfile] withExe pkg_descr $ \exe -> do info verbosity ("Building executable "++exeName exe) @@ -166,7 +167,7 @@ jhcPkgConf pd = let sline name sel = name ++ ": "++sel pd Just lib = library pd - comma = intercalate "," + comma = intercalate "," . map display in unlines [sline "name" (display . packageId) ,"exposed-modules: " ++ (comma (PD.exposedModules lib)) ,"hidden-modules: " ++ (comma (otherModules $ libBuildInfo lib)) diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -2,16 +2,17 @@ -- | -- Module : Distribution.Simple.LocalBuildInfo -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Definition of the 'LocalBuildInfo' data type. This is basically --- the information that is gathered by the end of the configuration --- step which could include package information from ghc-pkg, flags --- the user passed to configure, and the location of tools in the --- PATH. +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets +-- passed in to very many subsequent build actions. {- All rights reserved. @@ -43,15 +44,12 @@ (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.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - -- * Installation directories - module Distribution.Simple.InstallDirs, +module Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), + -- * Installation directories + module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs, - substPathTemplate, - - -- * Deprecated compat stuff - mkDataDir, + substPathTemplate ) where @@ -72,21 +70,21 @@ -- 'Distribution.Setup.ConfigFlags'. data LocalBuildInfo = LocalBuildInfo { installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various differnt - -- kinds of files - compiler :: Compiler, - -- ^ The compiler we're building with - buildDir :: FilePath, - -- ^ Where to build the package. - scratchDir :: FilePath, - -- ^ Where to put the result of the Hugs build. - packageDeps :: [PackageIdentifier], - -- ^ Which packages we depend on, /exactly/. - -- The 'Distribution.PackageDescription.PackageDescription' - -- specifies a set of build dependencies - -- that must be satisfied in terms of version ranges. This - -- field fixes those dependencies to the specific versions - -- available on this machine for this compiler. + -- ^ The installation directories for the various differnt + -- kinds of files + compiler :: Compiler, + -- ^ The compiler we're building with + buildDir :: FilePath, + -- ^ Where to build the package. + scratchDir :: FilePath, + -- ^ Where to put the result of the Hugs build. + packageDeps :: [PackageIdentifier], + -- ^ Which packages we depend on, /exactly/. + -- The 'Distribution.PackageDescription.PackageDescription' + -- specifies a set of build dependencies + -- that must be satisfied in terms of version ranges. This + -- field fixes those dependencies to the specific versions + -- available on this machine for this compiler. installedPkgs :: PackageIndex InstalledPackageInfo, -- ^ All the info about all installed packages. pkgDescrFile :: Maybe FilePath, @@ -102,7 +100,7 @@ withProfExe :: Bool, -- ^Whether to build executables for profiling. withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available + splitObjs :: Bool, -- ^Use -split-objs with GHC, if available stripExes :: Bool, -- ^Whether to strip executables during install progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables @@ -133,16 +131,8 @@ substPathTemplate :: PackageDescription -> LocalBuildInfo -> PathTemplate -> FilePath -substPathTemplate pkg_descr lbi = fromPathTemplate +substPathTemplate pkg_descr lbi = fromPathTemplate . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv + where env = initialPathTemplateEnv (packageId pkg_descr) (compilerId (compiler lbi)) - --- --------------------------------------------------------------------------- --- Deprecated compat stuff - -mkDataDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath -mkDataDir pkg_descr lbi copydest = - datadir (absoluteInstallDirs pkg_descr lbi copydest) -{-# DEPRECATED mkDataDir "use datadir :: InstallDirs -> FilePath" #-} diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs --- a/Distribution/Simple/NHC.hs +++ b/Distribution/Simple/NHC.hs @@ -2,11 +2,12 @@ -- | -- Module : Distribution.Simple.NHC -- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- +-- This module contains most of the NHC-specific code for configuring, building +-- and installing packages. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -50,6 +51,8 @@ import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..), withLib, withExe, hcOptions ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.BuildPaths @@ -59,25 +62,28 @@ , Flag, extensionsToFlags ) import Language.Haskell.Extension ( Extension(..) ) -import Distribution.Simple.Program +import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, requireProgram, lookupProgram, ConfiguredProgram(programVersion), programPath, nhcProgram, hmakeProgram, ldProgram, arProgram, rawSystemProgramConf ) import Distribution.Simple.Utils - ( die, info, findFileWithExtension, dotToSep, + ( die, info, findFileWithExtension, createDirectoryIfMissingVerbose, copyFileVerbose, smartCopySources ) import Distribution.Version ( Version(..), VersionRange(..), orLaterVersion ) import Distribution.Verbosity +import Distribution.Text + ( display ) + import System.FilePath ( (), (<.>), normalise, takeDirectory, dropExtension ) import System.Directory ( removeFile ) -import Control.Exception (try) import Data.List ( nub ) import Control.Monad ( when, unless ) +import Distribution.Compat.Exception -- ----------------------------------------------------------------------------- -- Configuring @@ -147,7 +153,8 @@ ++ extensionFlags ++ maybe [] (hcOptions NHC . libBuildInfo) (library pkg_descr) - ++ concat [ ["-package", packageName pkg] | pkg <- packageDeps lbi ] + ++ concat [ ["-package", display (packageName pkg) ] + | pkg <- packageDeps lbi ] ++ inFiles {- -- build any C sources @@ -168,11 +175,12 @@ let --cObjs = [ targetDir cFile `replaceExtension` objExtension -- | cFile <- cSources bi ] libFilePath = targetDir mkLibName (packageId pkg_descr) - hObjs = [ targetDir dotToSep m <.> objExtension + hObjs = [ targetDir ModuleName.toFilePath m <.> objExtension | m <- modules ] unless (null hObjs {-&& null cObjs-}) $ do - try (removeFile libFilePath) -- first remove library if it exists + -- first remove library if it exists + removeFile libFilePath `catchIO` \_ -> return () let arVerbosity | verbosity >= deafening = "v" | verbosity >= normal = "" @@ -205,7 +213,8 @@ ++ extensionFlags ++ maybe [] (hcOptions NHC . libBuildInfo) (library pkg_descr) - ++ concat [ ["-package", packageName pkg] | pkg <- packageDeps lbi ] + ++ concat [ ["-package", display (packageName pkg) ] + | pkg <- packageDeps lbi ] ++ inFiles ++ [exeName exe] @@ -216,12 +225,12 @@ | otherwise = ["-q"] --TODO: where to put this? it's duplicated in .Simple too -getModulePaths :: LocalBuildInfo -> BuildInfo -> [String] -> IO [FilePath] +getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath] getModulePaths lbi bi modules = sequence [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi) - (dotToSep module_) >>= maybe (notFound module_) (return . normalise) + (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise) | module_ <- modules ] - where notFound module_ = die $ "can't find source for module " ++ module_ + where notFound module_ = die $ "can't find source for module " ++ display module_ -- ----------------------------------------------------------------------------- -- Installing diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs --- a/Distribution/Simple/PackageIndex.hs +++ b/Distribution/Simple/PackageIndex.hs @@ -10,14 +10,12 @@ -- Copyright : (c) David Himmelstrup 2005, -- Bjorn Bringert 2007, -- Duncan Coutts 2008 --- License : BSD-like -- --- Maintainer : Duncan Coutts --- Stability : provisional +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- An index of packages. ------------------------------------------------------------------------------ +-- module Distribution.Simple.PackageIndex ( -- * Package index data type PackageIndex, @@ -52,6 +50,8 @@ brokenPackages, dependencyClosure, reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, dependencyInconsistencies, dependencyCycles, dependencyGraph, @@ -65,36 +65,44 @@ import qualified Data.Graph as Graph import qualified Data.Array as Array import Data.Array ((!)) -import Data.List (groupBy, sortBy, find) +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) +import Data.List (groupBy, sortBy, nub, find, isPrefixOf, tails) +#else +import Data.List (groupBy, sortBy, nub, find, isInfixOf) +#endif import Data.Monoid (Monoid(..)) import Data.Maybe (isNothing, fromMaybe) import Distribution.Package - ( PackageIdentifier, Package(..), packageName, packageVersion + ( PackageName(..), PackageIdentifier(..) + , Package(..), packageName, packageVersion , Dependency(Dependency), PackageFixedDeps(..) ) import Distribution.Version ( Version, withinRange ) -import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf) +import Distribution.Simple.Utils (lowercase, equating, comparing) #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) import Text.Read import qualified Text.Read.Lex as L #endif +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) +isInfixOf :: (Eq a) => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) +#endif + -- | The collection of information about packages from one or more 'PackageDB's. -- -- It can be searched effeciently by package name and version. -- -data Package pkg => PackageIndex pkg = PackageIndex - -- This index maps lower case package names to all the - -- 'InstalledPackageInfo' records matching that package name - -- case-insensitively. It includes all versions. +newtype Package pkg => PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. -- - -- This allows us to do case sensitive or insensitive lookups, and to find - -- all versions satisfying a dependency, all by varying how we filter. So - -- most queries will do a map lookup followed by a linear scan of the bucket. + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. -- - (Map String [pkg]) + (Map PackageName [pkg]) #if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) deriving (Show, Read) @@ -138,13 +146,17 @@ goodBucket _ [] = False goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 where - check pkgid [] = lowercase (packageName pkgid) == name - check pkgid (pkg':pkgs) = lowercase (packageName pkgid) == name + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name && pkgid < pkgid' && check pkgid' pkgs where pkgid' = packageId pkg' -mkPackageIndex :: Package pkg => Map String [pkg] -> PackageIndex pkg +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg mkPackageIndex index = assert (invariant (PackageIndex index)) (PackageIndex index) @@ -152,24 +164,24 @@ internalError name = error ("PackageIndex." ++ name ++ ": internal error") -- | Lookup a name in the index to get all packages that match that name --- case-insensitively. +-- case-sensitively. -- -lookup :: Package pkg => PackageIndex pkg -> String -> [pkg] -lookup (PackageIndex m) name = - case Map.lookup (lowercase name) m of - Nothing -> [] - Just pkgs -> pkgs +lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m --- | Build an index out of a bunch of 'Package's. -- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- -- If there are duplicates, later ones mask earlier ones. -- fromList :: Package pkg => [pkg] -> PackageIndex pkg fromList pkgs = mkPackageIndex . Map.map fixBucket . Map.fromListWith (++) - $ [ let key = (lowercase . packageName) pkg - in (key, [pkg]) + $ [ (packageName pkg, [pkg]) | pkg <- pkgs ] where fixBucket = -- out of groups of duplicates, later ones mask earlier ones @@ -181,6 +193,10 @@ -- can pick consistently among duplicates . sortBy (comparing packageId) +-- +-- * Updates +-- + -- | Merge two indexes. -- -- Packages from the second mask packages of the same exact name @@ -208,8 +224,7 @@ -- insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg insert pkg (PackageIndex index) = mkPackageIndex $ - let key = (lowercase . packageName) pkg - in Map.insertWith (\_ -> insertNoDup) key [pkg] index + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index where pkgid = packageId pkg insertNoDup [] = [pkg] @@ -220,10 +235,9 @@ -- | Internal delete helper. -- -delete :: Package pkg => String -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg delete name p (PackageIndex index) = mkPackageIndex $ - let key = lowercase name - in Map.update filterBucket key index + Map.update filterBucket name index where filterBucket = deleteEmptyBucket . filter (not . p) @@ -238,7 +252,7 @@ -- | Removes all packages with this (case-sensitive) name from the index. -- -deletePackageName :: Package pkg => String -> PackageIndex pkg -> PackageIndex pkg +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg deletePackageName name = delete name (\pkg -> packageName pkg == name) @@ -248,6 +262,10 @@ deleteDependency (Dependency name verstionRange) = delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-- +-- * Bulk queries +-- + -- | Get all the packages from the index. -- allPackages :: Package pkg => PackageIndex pkg -> [pkg] @@ -258,44 +276,12 @@ -- They are grouped by package name, case-sensitively. -- allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = - concatMap (groupBy (equating packageName)) (Map.elems m) +allPackagesByName (PackageIndex m) = Map.elems m --- | Does a case-insensitive search by package name. -- --- If there is only one package that compares case-insentiviely to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insentiviely but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insentiviely and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. +-- * Lookups -- -searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] -searchByName index name = - case groupBy (equating packageName) (lookup index name) of - [] -> None - [pkgs] -> Unambiguous pkgs - pkgss -> case find ((name==) . packageName . head) pkgss of - Just pkgs -> Unambiguous pkgs - Nothing -> Ambiguous pkgss -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] -searchByNameSubstring (PackageIndex m) searchterm = - [ pkg - | (name, pkgs) <- Map.toList m - , searchterm' `isInfixOf` name - , pkg <- pkgs ] - where searchterm' = lowercase searchterm - -- | Does a lookup by package id (name & version). -- -- Since multiple package DBs mask each other case-sensitively by package name, @@ -311,7 +297,7 @@ -- | Does a case-sensitive search by package name. -- -lookupPackageName :: Package pkg => PackageIndex pkg -> String -> [pkg] +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] lookupPackageName index name = [ pkg | pkg <- lookup index name , packageName pkg == name ] @@ -327,6 +313,51 @@ , packageName pkg == name , packageVersion pkg `withinRange` versionRange ] +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] +searchByName (PackageIndex m) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m + , lowercase name' == lname ] of + [] -> None + [(_,pkgs)] -> Unambiguous pkgs + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pkgs) -> Unambiguous pkgs + Nothing -> Ambiguous (map snd pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkg + | (PackageName name, pkgs) <- Map.toList m + , lsearchterm `isInfixOf` lowercase name + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + +-- +-- * Special queries +-- + -- | All packages that have dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing. @@ -374,18 +405,31 @@ reverseDependencyClosure :: PackageFixedDeps pkg => PackageIndex pkg -> [PackageIdentifier] - -> [PackageIdentifier] + -> [pkg] reverseDependencyClosure index = - map vertexToPkgId + map vertexToPkg . concatMap Tree.flatten . Graph.dfs reverseDepGraph . map (fromMaybe noSuchPkgId . pkgIdToVertex) where - (depGraph, vertexToPkgId, pkgIdToVertex) = dependencyGraph index + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" +topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out -- if the dependencies within it use consistent versions of each package. @@ -398,12 +442,13 @@ -- dependencyInconsistencies :: PackageFixedDeps pkg => PackageIndex pkg - -> [(String, [(PackageIdentifier, Version)])] + -> [(PackageName, [(PackageIdentifier, Version)])] dependencyInconsistencies index = [ (name, inconsistencies) | (name, uses) <- Map.toList inverseIndex , let inconsistencies = duplicatesBy uses - , not (null inconsistencies) ] + versions = map snd inconsistencies + , reallyIsInconsistent name (nub versions) ] where inverseIndex = Map.fromListWith (++) [ (packageName dep, [(packageId pkg, packageVersion dep)]) @@ -416,6 +461,21 @@ . groupBy (equating snd) . sortBy (comparing snd) + reallyIsInconsistent :: PackageName -> [Version] -> Bool + reallyIsInconsistent _ [] = False + reallyIsInconsistent name [v1, v2] = + case (mpkg1, mpkg2) of + (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 + && pkgid2 `notElem` depends pkg1 + _ -> True + where + pkgid1 = PackageIdentifier name v1 + pkgid2 = PackageIdentifier name v2 + mpkg1 = lookupPackageId index pkgid1 + mpkg2 = lookupPackageId index pkgid2 + + reallyIsInconsistent _ _ = True + -- | Find if there are any cycles in the dependency graph. If there are no -- cycles the result is @[]@. -- @@ -434,22 +494,23 @@ -- | Builds a graph of the package dependencies. -- --- Dependencies on other packages that are in the index are discarded. +-- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. -- dependencyGraph :: PackageFixedDeps pkg => PackageIndex pkg -> (Graph.Graph, - Graph.Vertex -> PackageIdentifier, + Graph.Vertex -> pkg, PackageIdentifier -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertexToPkgId, pkgIdToVertex) +dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) where graph = Array.listArray bounds [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] | pkg <- pkgs ] - vertexToPkgId vertex = pkgIdTable ! vertex + vertexToPkg vertex = pkgTable ! vertex pkgIdToVertex = binarySearch 0 topBound + pkgTable = Array.listArray bounds pkgs pkgIdTable = Array.listArray bounds (map packageId pkgs) pkgs = sortBy (comparing packageId) (allPackages index) topBound = length pkgs - 1 diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -1,19 +1,20 @@ ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.PreProcess --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace -- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable -- --- PreProcessors are programs or functions which input a filename and --- output a Haskell file. The general form of a preprocessor is input --- Foo.pp and output Foo.hs (where /pp/ is a unique extension that --- tells us which preprocessor to use eg. gc, ly, cpphs, x, y, etc.). --- Once a PreProcessor has been added to Cabal, either here or with --- 'Distribution.Simple.UserHooks', if Cabal finds a Foo.pp, it'll run the given --- preprocessor which should output a Foo.hs. +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. There is also a +-- 'PPSuffixHandler' which is a combination of a file extension and a function +-- for configuring a 'PreProcessor'. It defines a bunch of known built-in +-- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and +-- lists them in 'knownSuffixHandlers'. On top of this it provides a function +-- for actually preprocessing some sources given a bunch of known suffix +-- handlers. This module is not as good as it could be, it could really do with +-- a rewrite to address some of the problems we have with pre-processors. {- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace All rights reserved. @@ -50,38 +51,46 @@ ppSuffixes, PPSuffixHandler, PreProcessor(..), mkSimplePreProcessor, runSimplePreProcessor, ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit + ppHappy, ppAlex, ppUnlit ) where import Distribution.Simple.PreProcess.Unlit (unlit) -import Distribution.PackageDescription (PackageDescription(..), - BuildInfo(..), Executable(..), withExe, - Library(..), withLib, libModules) import Distribution.Package - ( Package(..) ) + ( Package(..), PackageName(..) ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..), withExe + , Library(..), withLib, libModules ) +import qualified Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo_(..) ) +import qualified Distribution.Simple.PackageIndex as PackageIndex + ( topologicalOrder, lookupPackageName, insert ) import Distribution.Simple.Compiler ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.BuildPaths (autogenModulesDir) +import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File , die, setupMessage, intercalate, copyFileVerbose - , findFileWithExtension, findFileWithExtension', dotToSep ) -import Distribution.Simple.Program (Program(..), ConfiguredProgram(..), - lookupProgram, programPath, - rawSystemProgramConf, rawSystemProgram, - greencardProgram, cpphsProgram, hsc2hsProgram, - c2hsProgram, happyProgram, alexProgram, - haddockProgram, ghcProgram) + , findFileWithExtension, findFileWithExtension' ) +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), lookupProgram, programPath + , rawSystemProgramConf, rawSystemProgram + , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram + , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) +import Distribution.System + ( OS(OSX), buildOS ) import Distribution.Version (Version(..)) import Distribution.Verbosity import Distribution.Text - ( display, simpleParse ) + ( display ) -import Control.Monad (when, unless, join) +import Control.Monad (when, unless) import Data.Maybe (fromMaybe) +import Data.List (nub) import System.Directory (getModificationTime, doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (), (<.>), @@ -130,7 +139,7 @@ -- This matters since only platform independent generated code can be -- inlcuded into a source tarball. platformIndependent :: Bool, - + -- TODO: deal with pre-processors that have implementaion dependent output -- eg alex and happy have --ghc flags. However we can't really inlcude -- ghc-specific code into supposedly portable source tarballs. @@ -187,13 +196,14 @@ modu verbosity builtinSuffixes biHandlers | modu <- otherModules bi] preprocessModule (hsSourceDirs bi) exeDir forSDist - (dropExtensions (modulePath theExe)) + --FIXME: we should not pretend it's a module name: + (ModuleName.simple (dropExtensions (modulePath theExe))) verbosity builtinSuffixes biHandlers where hc = compilerFlavor (compiler lbi) - builtinSuffixes - | hc == NHC = ["hs", "lhs", "gc"] - | otherwise = ["hs", "lhs"] - localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + builtinSuffixes + | hc == NHC = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] -- |Find the first extension of the file that exists, and preprocess it -- if required. @@ -201,7 +211,7 @@ :: [FilePath] -- ^source directories -> FilePath -- ^build directory -> Bool -- ^preprocess for sdist - -> String -- ^module name + -> ModuleName -- ^module name -> Verbosity -- ^verbosity -> [String] -- ^builtin suffixes -> [(String, PreProcessor)] -- ^possible preprocessors @@ -209,21 +219,23 @@ preprocessModule searchLoc buildLoc forSDist modu verbosity builtinSuffixes handlers = do -- look for files in the various source dirs with this module name -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc (dotToSep modu) + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc + (ModuleName.toFilePath modu) case psrcFiles of -- no preprocessor file exists, look for an ordinary source file Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc (dotToSep modu) + bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc + (ModuleName.toFilePath modu) case bsrcFiles of - Nothing -> die ("can't find source for " ++ modu ++ " in " - ++ intercalate ", " searchLoc) - _ -> return () + Nothing -> die $ "can't find source for " ++ display modu + ++ " in " ++ intercalate ", " searchLoc + _ -> return () -- found a pre-processable file in one of the source dirs Just (psrcLoc, psrcRelFile) -> do let (srcStem, ext) = splitExtension psrcRelFile psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Internal error in preProcess module: Just expected") - (lookup (tailNotNull ext) handlers) + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup (tailNotNull ext) handlers) -- Preprocessing files for 'sdist' is different from preprocessing -- for 'build'. When preprocessing for sdist we preprocess to -- avoid that the user has to have the preprocessors available. @@ -235,13 +247,14 @@ when (not forSDist || forSDist && platformIndependent pp) $ do -- look for existing pre-processed source file in the dest dir to -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] (dotToSep modu) - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> do + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] + (ModuleName.toFilePath modu) + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> do btime <- getModificationTime ppsrcFile - ptime <- getModificationTime psrcFile - return (btime < ptime) + ptime <- getModificationTime psrcFile + return (btime < ptime) when recomp $ do let destDir = buildLoc dirName srcStem createDirectoryIfMissingVerbose verbosity True destDir @@ -272,9 +285,9 @@ ppUnlit = PreProcessor { platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> do - contents <- readUTF8File inFile - either (writeUTF8File outFile) die (unlit inFile contents) + runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) die (unlit inFile contents) } ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor @@ -306,6 +319,7 @@ -- using cpphs --unlit instead. ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else []) ++ (if use_optP_P lbi then ["-optP-P"] else []) + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] ++ ["-o", outFile, inFile] ++ extraArgs } @@ -317,11 +331,16 @@ PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity cpphsProgram (withPrograms lbi) $ + rawSystemProgram verbosity cpphsProg $ ("-O" ++ outFile) : inFile : "--noline" : "--strip" - : extraArgs + : (if cpphsVersion >= Version [1,6] [] + then ["--include="++ (autogenModulesDir lbi cppHeaderName)] + else []) + ++ extraArgs } + where Just cpphsProg = lookupProgram cpphsProgram (withPrograms lbi) + Just cpphsVersion = programVersion cpphsProg -- Haddock versions before 0.8 choke on #line and #file pragmas. Those -- pragmas are necessary for correct links when we preprocess. So use @@ -334,42 +353,61 @@ _ -> True ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi = pp - where pp = standardPP lbi hsc2hsProgram flags - flags = case fmap versionTags . join . fmap programVersion - . lookupProgram hsc2hsProgram . withPrograms $ lbi of - -- Just to make things complicated, the hsc2hs bundled with - -- ghc uses ghc as the C compiler, so to pass C flags we - -- have to use an additional layer of escaping. Grrr. - Just ["ghc"] -> - let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) - in [ "--cc=" ++ programPath ghcProg - , "--ld=" ++ programPath ghcProg ] - ++ -- Don't magically link in haskell98, rts and base - -- This is particularly important during the GHC build - -- itself, as they might not exist yet - ( case (programVersion ghcProg, simpleParse "6.9") of - (Just v1, Just v2) - | v1 >= v2 -> [ "--lflag=-no-auto-link-packages" ] - _ -> [] - ) - ++ [ "--cflag=-optc" ++ opt | opt <- ccOptions bi - ++ cppOptions bi ] - ++ [ "--cflag=" ++ opt | pkg <- packageDeps lbi - , opt <- ["-package" - ,display pkg] ] - ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi] - ++ [ "--lflag=-optl" ++ opt | opt <- getLdOptions bi ] +ppHsc2hs bi lbi = standardPP lbi hsc2hsProgram $ + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg ] - _ -> [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] - ++ [ "--cflag=" ++ opt | opt <- ccOptions bi ] - ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi ] - ++ [ "--lflag=" ++ opt | opt <- getLdOptions bi ] + -- Additional gcc options + ++ [ "--cflag=" ++ opt | opt <- programArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programArgs gccProg ] + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] + + -- Options from the current package: + ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi ] + ++ [ "--lflag=" ++ opt | opt <- getLdOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + where + pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) + Just gccProg = lookupProgram gccProgram (withPrograms lbi) + isOSX = case buildOS of OSX -> True; _ -> False + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index + _ -> error "No (or multiple) ghc rts package is registered!!" + getLdOptions :: BuildInfo -> [String] getLdOptions bi = map ("-L" ++) (extraLibDirs bi) ++ map ("-l" ++) (extraLibs bi) - ++ ldOptions bi + ++ PD.ldOptions bi ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppC2hs bi lbi @@ -388,8 +426,8 @@ getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi = hcDefines (compiler lbi) - ++ ["-I" ++ dir | dir <- includeDirs bi] - ++ [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] hcDefines :: Compiler -> [String] hcDefines comp = @@ -408,21 +446,28 @@ versionInt (Version { versionBranch = [] }) = "1" versionInt (Version { versionBranch = [n] }) = show n versionInt (Version { versionBranch = n1:n2:_ }) - = show n1 ++ take 2 ('0' : show n2) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor ppHappy _ lbi = pp { platformIndependent = True } where pp = standardPP lbi happyProgram (hcFlags hc) hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags _ = [] + hcFlags GHC = ["-agc"] + hcFlags _ = [] ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor ppAlex _ lbi = pp { platformIndependent = True } where pp = standardPP lbi alexProgram (hcFlags hc) hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags _ = [] + hcFlags GHC = ["-g"] + hcFlags _ = [] standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor standardPP lbi prog args = diff --git a/Distribution/Simple/PreProcess/Unlit.hs b/Distribution/Simple/PreProcess/Unlit.hs --- a/Distribution/Simple/PreProcess/Unlit.hs +++ b/Distribution/Simple/PreProcess/Unlit.hs @@ -2,9 +2,8 @@ -- | -- Module : Distribution.Simple.PreProcess.Unlit -- Copyright : ... --- --- Maintainer : Malcolm Wallace --- Stability : Stable +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Remove the \"literal\" markups from a Haskell source file, including diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -2,14 +2,24 @@ -- | -- Module : Distribution.Simple.Program -- Copyright : Isaac Jones 2006 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC, Hugs -- --- Explanation: A program is basically a name, a location, and some --- arguments. +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable -- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramConfiguration' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramConfiguration' which contains them all. +-- -- One nice thing about using it is that any program that is -- registered with Cabal will get some \"configure\" and \".cabal\" -- helpers like --with-foo-args --foo-path= and extra-foo-args. @@ -44,16 +54,22 @@ , ProgramConfiguration , emptyProgramConfiguration , defaultProgramConfiguration + , restoreProgramConfiguration , addKnownProgram + , addKnownPrograms , lookupKnownProgram , knownPrograms , userSpecifyPath + , userSpecifyPaths , userMaybeSpecifyPath , userSpecifyArgs + , userSpecifyArgss , userSpecifiedArgs , lookupProgram , updateProgram + , configureProgram , configureAllKnownPrograms + , reconfigurePrograms , requireProgram , rawSystemProgramConf , rawSystemProgramStdoutConf @@ -66,6 +82,7 @@ , jhcProgram , hugsProgram , ffihugsProgram + , gccProgram , ranlibProgram , arProgram , stripProgram @@ -83,35 +100,40 @@ , pkgConfigProgram ) where +import Data.List (foldl') +import Data.Maybe (catMaybes) import qualified Data.Map as Map -import Distribution.Simple.Utils (die, debug, warn, rawSystemExit, - rawSystemStdout, rawSystemStdout', - withTempFile) + +import Distribution.Simple.Utils + (die, debug, warn, rawSystemExit, rawSystemStdout) import Distribution.Version ( Version(..), VersionRange(AnyVersion), withinRange ) import Distribution.Text ( simpleParse, display ) import Distribution.Verbosity -import System.Directory (doesFileExist, removeFile, findExecutable, - getTemporaryDirectory) -import System.FilePath (dropExtension) -import System.IO (hClose) -import System.IO.Error (try) +import System.Directory + ( doesFileExist, findExecutable ) import Control.Monad (join, foldM) -import Control.Exception as Exception (catch) +import Distribution.Compat.Exception (catchExit, catchIO) -- | Represents a program which can be configured. data Program = Program { -- | The simple name of the program, eg. ghc programName :: String, - + -- | A function to search for the program if it's location was not - -- specified by the user. Usually this will just be a + -- specified by the user. Usually this will just be a programFindLocation :: Verbosity -> IO (Maybe FilePath), - + -- | Try to find the version of the program. For many programs this is -- not possible or is not necessary so it's ok to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), + + -- | A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). It is + -- allowed to return additional flags that will be passed to the + -- program on every invocation. + programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg] } type ProgArg = String @@ -119,7 +141,7 @@ data ConfiguredProgram = ConfiguredProgram { -- | Just the name again programId :: String, - + -- | The version of this program, if it is known. programVersion :: Maybe Version, @@ -129,8 +151,8 @@ programArgs :: [ProgArg], -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation - } deriving (Read, Show) + programLocation :: ProgramLocation + } deriving (Read, Show, Eq) -- | Where a program was found. Also tells us whether it's specifed by user or -- not. This includes not just the path, but the program as well. @@ -140,7 +162,7 @@ -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 | FoundOnSystem { locationPath :: FilePath } -- ^The location of the program, as located by searching PATH. - deriving (Read, Show) + deriving (Read, Show, Eq) -- ------------------------------------------------------------ -- * Programs functions @@ -158,8 +180,12 @@ -- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } -- simpleProgram :: String -> Program -simpleProgram name = - Program name (findProgramOnPath name) (\_ _ -> return Nothing) +simpleProgram name = Program { + programName = name, + programFindLocation = findProgramOnPath name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } -- | Look for a program on the path. findProgramOnPath :: FilePath -> Verbosity -> IO (Maybe FilePath) @@ -183,7 +209,8 @@ -> IO (Maybe Version) findProgramVersion versionArg selectVersion verbosity path = do str <- rawSystemStdout verbosity path [versionArg] - `Exception.catch` \_ -> return "" + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") let version :: Maybe Version version = simpleParse (selectVersion str) case version of @@ -217,7 +244,7 @@ defaultProgramConfiguration :: ProgramConfiguration defaultProgramConfiguration = - foldl (flip addKnownProgram) emptyProgramConfiguration builtinPrograms + restoreProgramConfiguration builtinPrograms emptyProgramConfiguration -- internal helpers: updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) @@ -241,20 +268,36 @@ [ (emptyProgramConfiguration { configuredProgs = Map.fromList s' }, r) | (s', r) <- readsPrec p s ] +-- | The Read\/Show instance does not preserve all the unconfigured 'Programs' +-- because 'Program' is not in Read\/Show because it contains functions. So to +-- fully restore a deserialised 'ProgramConfiguration' use this function to add +-- back all the known 'Program's. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +-- +restoreProgramConfiguration :: [Program] -> ProgramConfiguration + -> ProgramConfiguration +restoreProgramConfiguration = addKnownPrograms + -- ------------------------------- -- Managing unconfigured programs -- | Add a known program that we may configure later addKnownProgram :: Program -> ProgramConfiguration -> ProgramConfiguration addKnownProgram prog = updateUnconfiguredProgs $ - Map.insert (programName prog) (prog, Nothing, []) + Map.insertWith combine (programName prog) (prog, Nothing, []) + where combine _ (_, path, args) = (prog, path, args) +addKnownPrograms :: [Program] -> ProgramConfiguration -> ProgramConfiguration +addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs + lookupKnownProgram :: String -> ProgramConfiguration -> Maybe Program lookupKnownProgram name = fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs knownPrograms :: ProgramConfiguration -> [(Program, Maybe ConfiguredProgram)] -knownPrograms conf = +knownPrograms conf = [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) , let p' = Map.lookup (programName p) (configuredProgs conf) ] @@ -287,10 +330,30 @@ (flip Map.update name $ \prog -> Just prog { programArgs = programArgs prog ++ args' }) +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +-- +userSpecifyPaths :: [(String, FilePath)] + -> ProgramConfiguration + -> ProgramConfiguration +userSpecifyPaths paths conf = + foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +-- +userSpecifyArgss :: [(String, [ProgArg])] + -> ProgramConfiguration + -> ProgramConfiguration +userSpecifyArgss argss conf = + foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss + +-- | Get the path that has been previously specified for a program, if any. +-- userSpecifiedPath :: Program -> ProgramConfiguration -> Maybe FilePath userSpecifiedPath prog = join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs +-- | Get any extra args that have been previously specified for a program. +-- userSpecifiedArgs :: Program -> ProgramConfiguration -> [ProgArg] userSpecifiedArgs prog = maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs @@ -313,7 +376,7 @@ -- | Try to configure a specific program. If the program is already included in -- the colleciton of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured sucessfully it gets +-- location and arguments. If the program gets configured sucessfully it gets -- added to the configured collection. -- -- Note that it is not a failure if the program cannot be configured. It's only @@ -323,7 +386,7 @@ -- The reason for it not being a failure at this stage is that we don't know up -- front all the programs we will need, so we try to configure them all. -- To verify that a program was actually sucessfully configured use --- 'requireProgram'. +-- 'requireProgram'. -- configureProgram :: Verbosity -> Program @@ -340,29 +403,61 @@ then return (Just (UserSpecified path)) else findProgramOnPath path verbosity >>= maybe (die notFound) (return . Just . UserSpecified) - where notFound = "Cannot find " ++ name ++ " at " - ++ path ++ " or on the path" + where notFound = "Cannot find the program '" ++ name ++ "' at '" + ++ path ++ "' or on the path" case maybeLocation of Nothing -> return conf Just location -> do version <- programFindVersion prog verbosity (locationPath location) - let configuredProg = ConfiguredProgram { + let configuredProg = ConfiguredProgram { programId = name, programVersion = version, programArgs = userSpecifiedArgs prog conf, programLocation = location } - return (updateConfiguredProgs (Map.insert name configuredProg) conf) + extraArgs <- programPostConf prog verbosity configuredProg + let configuredProg' = configuredProg { + programArgs = extraArgs ++ programArgs configuredProg + } + return (updateConfiguredProgs (Map.insert name configuredProg') conf) --- | Try to configure all the known programs that have not yet been configured. -configureAllKnownPrograms :: Verbosity +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +configurePrograms :: Verbosity + -> [Program] -> ProgramConfiguration -> IO ProgramConfiguration +configurePrograms verbosity progs conf = + foldM (flip (configureProgram verbosity)) conf progs + +-- | Try to configure all the known programs that have not yet been configured. +configureAllKnownPrograms :: Verbosity + -> ProgramConfiguration + -> IO ProgramConfiguration configureAllKnownPrograms verbosity conf = - foldM (flip (configureProgram verbosity)) conf - [ prog | (prog,_,_) <- Map.elems (unconfiguredProgs conf - `Map.difference` configuredProgs conf) ] + configurePrograms verbosity + [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf + where + notYetConfigured = unconfiguredProgs conf + `Map.difference` configuredProgs conf +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +-- +reconfigurePrograms :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramConfiguration + -> IO ProgramConfiguration +reconfigurePrograms verbosity paths argss conf = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ conf + + where + progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] + -- | Check that a program is configured and available to be run. -- -- Additionally check that the version of the program number is suitable. @@ -373,12 +468,12 @@ requireProgram :: Verbosity -> Program -> VersionRange -> ProgramConfiguration -> IO (ConfiguredProgram, ProgramConfiguration) requireProgram verbosity prog range conf = do - + -- If it's not already been configured, try to configure it now conf' <- case lookupProgram prog conf of Nothing -> configureProgram verbosity prog conf Just _ -> return conf - + case lookupProgram prog conf' of Nothing -> die notFound Just configuredProg @@ -471,6 +566,7 @@ , cpphsProgram , greencardProgram -- platform toolchain + , gccProgram , ranlibProgram , arProgram , stripProgram @@ -553,6 +649,10 @@ _ -> "" } +gccProgram :: Program +gccProgram = (simpleProgram "gcc") { + programFindVersion = findProgramVersion "-dumpversion" id + } ranlibProgram :: Program ranlibProgram = simpleProgram "ranlib" @@ -565,32 +665,12 @@ hsc2hsProgram :: Program hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = \verbosity path -> do - maybeVersion <- findProgramVersion "--version" (\str -> + programFindVersion = + findProgramVersion "--version" $ \str -> -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" case words str of (_:_:ver:_) -> ver - _ -> "") verbosity path - - -- It turns out that it's important to know if hsc2hs is using gcc or ghc - -- as it's C compiler since this affects how we escape C options. - -- So here's a cunning hack, we make a temp .hsc file and call: - -- hsch2s tmp.hsc --cflag=--version - -- which passes --version through to ghc/gcc and we look at the result - -- to see if it was indeed ghc or not. - case maybeVersion of - Nothing -> return Nothing - Just version -> do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".hsc" $ \hsc hnd -> do - hClose hnd - (str, _) <- rawSystemStdout' verbosity path [hsc, "--cflag=--version"] - try $ removeFile (dropExtension hsc ++ "_hsc_make.c") - case words str of - (_:"Glorious":"Glasgow":"Haskell":_) - -> return $ Just version { versionTags = ["ghc"] } - _ -> return $ Just version - + _ -> "" } c2hsProgram :: Program diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -2,13 +2,25 @@ -- | -- Module : Distribution.Simple.Register -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Perform the \"@.\/setup register@\" action. --- Uses a drop-file for HC-PKG. See also "Distribution.InstalledPackageInfo". +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- popular so we also provide a way to simply generate the package registration +-- file which then must be manually passed to @ghc-pkg@. It is possible to +-- generate registration information for where the package is to be installed, +-- or alternatively to register the package inplace in the build tree. The +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- mixes it all in in this module, which is rather unsatisfactory. The script +-- generation and the unregister feature are not well used or tested. {- Copyright (c) 2003-2004, Isaac Jones All rights reserved. @@ -42,16 +54,16 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Register ( - register, - unregister, + register, + unregister, writeInstalledConfig, - removeInstalledConfig, + removeInstalledConfig, removeRegScripts, ) where import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), InstallDirs(..), - absoluteInstallDirs) + absoluteInstallDirs) import Distribution.Simple.BuildPaths (haddockName) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) @@ -66,11 +78,11 @@ import Distribution.Package ( Package(..), packageName ) import Distribution.InstalledPackageInfo - (InstalledPackageInfo, showInstalledPackageInfo, - emptyInstalledPackageInfo) + ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) + , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, copyFileVerbose + ( createDirectoryIfMissingVerbose, copyFileVerbose, writeFileAtomic , die, info, notice, setupMessage ) import Distribution.System ( OS(..), buildOS ) @@ -81,7 +93,7 @@ import System.Directory (removeFile, getCurrentDirectory, removeDirectoryRecursive, setPermissions, getPermissions, - Permissions(executable)) + Permissions(executable)) import System.IO.Error (try) import Control.Monad (when) @@ -118,7 +130,7 @@ (fromFlag (regGenPkgConf regFlags)) verbosity = fromFlag (regVerbosity regFlags) packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags) - inplace = fromFlag (regInPlace regFlags) + inplace = fromFlag (regInPlace regFlags) message | genPkgConf = "Writing package registration file: " ++ genPkgConfigFile ++ " for" | genScript = "Writing registration script: " @@ -127,23 +139,23 @@ setupMessage verbosity message (packageId pkg_descr) case compilerFlavor (compiler lbi) of - GHC -> do - config_flags <- case packageDB of + GHC -> do + config_flags <- case packageDB of GlobalPackageDB -> return [] UserPackageDB -> return ["--user"] SpecificPackageDB db -> return ["--package-conf=" ++ db] - let instConf | genPkgConf = genPkgConfigFile + let instConf | genPkgConf = genPkgConfigFile | inplace = inplacePkgConfigFile distPref - | otherwise = installedPkgConfigFile distPref + | otherwise = installedPkgConfigFile distPref when (genPkgConf || not genScript) $ do info verbosity ("create " ++ instConf) writeInstalledConfig distPref pkg_descr lbi inplace (Just instConf) let register_flags = let conf = if genScript && not isWindows - then ["-"] - else [instConf] + then ["-"] + else [instConf] in "update" : conf let allFlags = config_flags ++ register_flags @@ -157,11 +169,11 @@ _ -> rawSystemProgram verbosity pkgTool allFlags Hugs -> do - when inplace $ die "--inplace is not supported with Hugs" + when inplace $ die "--inplace is not supported with Hugs" let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - createDirectoryIfMissingVerbose verbosity True (libdir installDirs) - copyFileVerbose verbosity (installedPkgConfigFile distPref) - (libdir installDirs "package.conf") + createDirectoryIfMissingVerbose verbosity True (libdir installDirs) + copyFileVerbose verbosity (installedPkgConfigFile distPref) + (libdir installDirs "package.conf") JHC -> notice verbosity "registering for JHC (nothing to do)" NHC -> notice verbosity "registering nhc98 (nothing to do)" _ -> die "only registering with GHC/Hugs/jhc/nhc98 is implemented" @@ -178,7 +190,7 @@ let instConfDefault | inplace = inplacePkgConfigFile distPref | otherwise = installedPkgConfigFile distPref instConf = fromMaybe instConfDefault instConfOverride - writeFile instConf (pkg_config ++ "\n") + writeFileAtomic instConf (pkg_config ++ "\n") -- |Create a string suitable for writing out to the package config file showInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo -> Bool @@ -209,28 +221,28 @@ -- Making the InstalledPackageInfo mkInstalledPackageInfo - :: FilePath - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> IO InstalledPackageInfo -mkInstalledPackageInfo distPref pkg_descr lbi inplace = do + :: FilePath + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> IO InstalledPackageInfo +mkInstalledPackageInfo distPref pkg_descr lbi inplace = do pwd <- getCurrentDirectory - let - lib = fromJust (library pkg_descr) -- checked for Nothing earlier + let + lib = fromJust (library pkg_descr) -- checked for Nothing earlier bi = libBuildInfo lib - build_dir = pwd buildDir lbi + build_dir = pwd buildDir lbi installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - inplaceDirs = (absoluteInstallDirs pkg_descr lbi NoCopyDest) { + inplaceDirs = (absoluteInstallDirs pkg_descr lbi NoCopyDest) { datadir = pwd, datasubdir = distPref, docdir = inplaceDocdir, htmldir = inplaceHtmldir, haddockdir = inplaceHtmldir } - where inplaceDocdir = pwd distPref "doc" - inplaceHtmldir = inplaceDocdir "html" - packageName pkg_descr + where inplaceDocdir = pwd distPref "doc" + inplaceHtmldir = inplaceDocdir "html" + display (packageName pkg_descr) (absinc,relinc) = partition isAbsolute (includeDirs bi) installIncludeDir | null (installIncludes bi) = [] | otherwise = [includedir installDirs] @@ -247,20 +259,20 @@ && null (otherModules bi) hasLibrary = hasModules || not (null (cSources bi)) in - return emptyInstalledPackageInfo{ + return InstalledPackageInfo { IPI.package = packageId pkg_descr, IPI.license = license pkg_descr, IPI.copyright = copyright pkg_descr, IPI.maintainer = maintainer pkg_descr, - IPI.author = author pkg_descr, + IPI.author = author pkg_descr, IPI.stability = stability pkg_descr, - IPI.homepage = homepage pkg_descr, - IPI.pkgUrl = pkgUrl pkg_descr, - IPI.description = description pkg_descr, - IPI.category = category pkg_descr, - IPI.exposed = True, - IPI.exposedModules = exposedModules lib, - IPI.hiddenModules = otherModules bi, + IPI.homepage = homepage pkg_descr, + IPI.pkgUrl = pkgUrl pkg_descr, + IPI.description = description pkg_descr, + IPI.category = category pkg_descr, + IPI.exposed = libExposed lib, + IPI.exposedModules = exposedModules lib, + IPI.hiddenModules = otherModules bi, IPI.importDirs = [ libraryDir | hasModules ], IPI.libraryDirs = if hasLibrary then libraryDir : extraLibDirs bi @@ -268,18 +280,22 @@ IPI.hsLibraries = ["HS" ++ display (packageId pkg_descr) | hasLibrary ], IPI.extraLibraries = extraLibs bi, + IPI.extraGHCiLibraries= [], IPI.includeDirs = absinc ++ if inplace then map (pwd ) relinc else installIncludeDir, - IPI.includes = includes bi, + IPI.includes = includes bi, IPI.depends = packageDeps lbi, IPI.hugsOptions = concat [opts | (Hugs,opts) <- options bi], - IPI.ccOptions = ccOptions bi, + IPI.ccOptions = [], -- NB. NOT ccOptions bi! + -- We don't want cc-options to be + -- propagated to C ompilations in other + -- packages. IPI.ldOptions = ldOptions bi, IPI.frameworkDirs = [], IPI.frameworks = frameworks bi, - IPI.haddockInterfaces = [haddockInterfaceDir haddockName pkg_descr], - IPI.haddockHTMLs = [haddockHtmlDir] + IPI.haddockInterfaces = [haddockInterfaceDir haddockName pkg_descr], + IPI.haddockHTMLs = [haddockHtmlDir] } -- ----------------------------------------------------------------------------- @@ -294,7 +310,7 @@ setupMessage verbosity "Unregistering" (packageId pkg_descr) case compilerFlavor (compiler lbi) of GHC -> do - config_flags <- case packageDB of + config_flags <- case packageDB of GlobalPackageDB -> return [] UserPackageDB -> return ["--user"] SpecificPackageDB db -> return ["--package-conf=" ++ db] @@ -302,17 +318,17 @@ let removeCmd = ["unregister", display (packageId pkg_descr)] let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) allArgs = removeCmd ++ config_flags - if genScript + if genScript then rawSystemEmit pkgTool unregScriptLocation allArgs else rawSystemProgram verbosity pkgTool allArgs Hugs -> do try $ removeDirectoryRecursive (libdir installDirs) - return () + return () NHC -> do try $ removeDirectoryRecursive (libdir installDirs) - return () + return () _ -> - die ("only unregistering with GHC and Hugs is implemented") + die ("only unregistering with GHC and Hugs is implemented") -- |Like rawSystemProgram, but emits to a script instead of exiting. -- FIX: chmod +x? @@ -323,8 +339,8 @@ rawSystemEmit prog scriptName extraArgs = case buildOS of Windows -> - writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) - _ -> do writeFile scriptName ("#!/bin/sh\n\n" + writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args) + _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n" ++ (path ++ concatMap (' ':) args) ++ "\n") p <- getPermissions scriptName @@ -341,8 +357,8 @@ rawSystemPipe prog scriptName pipeFrom extraArgs = case buildOS of Windows -> - writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) - _ -> do writeFile scriptName ("#!/bin/sh\n\n" + writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args) + _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n" ++ "echo '" ++ escapeForShell pipeFrom ++ "' | " ++ (path ++ concatMap (' ':) args) diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -2,13 +2,29 @@ -- | -- Module : Distribution.Simple.Setup -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Data types and parser for the standard command-line --- setup. Will also return commands it doesn't know about. +-- This is a big module, but not very complicated. The code is very regular +-- and repetitive. It defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- read and written from files. This would allow us to save configure flags in +-- config files. {- All rights reserved. @@ -49,6 +65,7 @@ HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + buildVerbose, CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, MakefileFlags(..), emptyMakefileFlags, defaultMakefileFlags, makefileCommand, RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, @@ -57,6 +74,7 @@ TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, CopyDest(..), configureArgs, configureOptions, + installDirsOptions, defaultDistPref, @@ -82,7 +100,9 @@ import Distribution.Simple.Utils ( wrapLine, lowercase ) import Distribution.Simple.Program (Program(..), ProgramConfiguration, - knownPrograms) + knownPrograms, + addKnownProgram, emptyProgramConfiguration, + haddockProgram) import Distribution.Simple.InstallDirs ( InstallDirs(..), CopyDest(..), PathTemplate, toPathTemplate, fromPathTemplate ) @@ -253,7 +273,6 @@ configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files configDistPref :: Flag FilePath, -- ^"dist" prefix - configVerbose :: Verbosity, -- ^verbosity level (deprecated) configVerbosity :: Flag Verbosity, -- ^verbosity level configUserInstall :: Flag Bool, -- ^The --user\/--global flag configPackageDB :: Flag PackageDB, -- ^Which package DB to use @@ -278,7 +297,6 @@ configProgPrefix = Flag (toPathTemplate ""), configProgSuffix = Flag (toPathTemplate ""), configDistPref = Flag defaultDistPref, - configVerbose = normal, configVerbosity = Flag normal, configUserInstall = Flag False, --TODO: reverse this configGHCiLib = Flag True, @@ -293,7 +311,7 @@ shortDesc = "Prepare to build the package." longDesc = Just (\_ -> programFlagsDescription progConf) defaultFlags = defaultConfigFlags progConf - options showOrParseArgs = + options showOrParseArgs = configureOptions showOrParseArgs ++ programConfigurationPaths progConf showOrParseArgs configProgramPaths (\v fs -> fs { configProgramPaths = v }) @@ -304,7 +322,9 @@ configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs = [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) - ,optionDistPref configDistPref (\d flags -> flags { configDistPref = d }) + ,optionDistPref + configDistPref (\d flags -> flags { configDistPref = d }) + showOrParseArgs ,option [] ["compiler"] "compiler" configHcFlavor (\v flags -> flags { configHcFlavor = v }) @@ -322,65 +342,16 @@ "give the path to the package tool" configHcPkg (\v flags -> flags { configHcPkg = v }) (reqArgFlag "PATH") - - ,option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - ,option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - ,option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - ,option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - ,option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - ,option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - ,option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - ,option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - ,option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - ,option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - - ,option "b" ["scratchdir"] + ] + ++ map liftInstallDirs installDirsOptions + ++ [option "b" ["scratchdir"] "directory to receive the built package [dist/scratch]" configScratchDir (\v flags -> flags { configScratchDir = v }) (reqArgFlag "DIR") ,option "" ["program-prefix"] "prefix to be applied to installed executables" - configProgPrefix + configProgPrefix (\v flags -> flags { configProgPrefix = v }) (reqPathTemplateArgFlag "PREFIX") @@ -477,29 +448,84 @@ ,option "" ["constraint"] "A list of additional constraints on the dependencies." configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" + (reqArg "DEPENDENCY" (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) (map (\x -> display x))) ] - where + where readFlagList :: String -> FlagAssignment readFlagList = map tagWithValue . words where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) tagWithValue fname = (FlagName (lowercase fname), True) - + showFlagList :: FlagAssignment -> [String] showFlagList fs = [ if not set then '-':fname else fname | (FlagName fname, set) <- fs] - installDirArg _sf _lf d get set = reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate.get.configInstallDirs) - (\v flags -> flags { configInstallDirs = - set (fmap toPathTemplate v) (configInstallDirs flags)}) + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) - reqPathTemplateArgFlag title _sf _lf d get set = reqArgFlag title _sf _lf d - (fmap fromPathTemplate.get) - (\v flags -> set (fmap toPathTemplate v) flags) + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag title _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + emptyConfigFlags :: ConfigFlags emptyConfigFlags = mempty @@ -522,7 +548,6 @@ configInstallDirs = mempty, configScratchDir = mempty, configDistPref = mempty, - configVerbose = normal, configVerbosity = mempty, configUserInstall = mempty, configPackageDB = mempty, @@ -535,7 +560,7 @@ configConfigurationsFlags = mempty } mappend a b = ConfigFlags { - configPrograms = configPrograms a, + configPrograms = configPrograms b, configProgramPaths = combine configProgramPaths, configProgramArgs = combine configProgramArgs, configHcFlavor = combine configHcFlavor, @@ -552,7 +577,6 @@ configInstallDirs = combine configInstallDirs, configScratchDir = combine configScratchDir, configDistPref = combine configDistPref, - configVerbose = fromFlagOrDefault (configVerbose a) (configVerbosity b), configVerbosity = combine configVerbosity, configUserInstall = combine configUserInstall, configPackageDB = combine configPackageDB, @@ -572,20 +596,20 @@ -- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) data CopyFlags = CopyFlags { - copyDest :: CopyDest, - copyDest' :: Flag CopyDest, + copyDest :: Flag CopyDest, copyDistPref :: Flag FilePath, - copyVerbose :: Verbosity, + copyUseWrapper :: Flag Bool, + copyInPlace :: Flag Bool, copyVerbosity :: Flag Verbosity } deriving Show defaultCopyFlags :: CopyFlags defaultCopyFlags = CopyFlags { - copyDest = NoCopyDest, - copyDest' = Flag NoCopyDest, + copyDest = Flag NoCopyDest, copyDistPref = Flag defaultDistPref, - copyVerbose = normal, + copyUseWrapper = Flag False, + copyInPlace = Flag False, copyVerbosity = Flag normal } @@ -597,19 +621,32 @@ longDesc = Just $ \_ -> "Does not call register, and allows a prefix at install time\n" ++ "Without the --destdir flag, configure determines location.\n" - options _ = + options showOrParseArgs = [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - ,optionDistPref copyDistPref (\d flags -> flags { copyDistPref = d }) + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + copyUseWrapper (\v flags -> flags { copyUseWrapper = v }) + (boolOpt [] []) + + ,optionDistPref + copyDistPref (\d flags -> flags { copyDistPref = d }) + showOrParseArgs + + ,option "" ["inplace"] + "copy the package in the install subdirectory of the dist prefix, so it can be used without being installed" + copyInPlace (\v flags -> flags { copyInPlace = v }) + trueArg + ,option "" ["destdir"] "directory to copy files to, prepended to installation directories" - copyDest' (\v flags -> flags { copyDest' = v }) + copyDest (\v flags -> flags { copyDest = v }) (reqArg "DIR" (succeedReadE (Flag . CopyTo)) (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) ,option "" ["copy-prefix"] "[DEPRECATED, directory to copy files to instead of prefix]" - copyDest' (\v flags -> flags { copyDest' = v }) + copyDest (\v flags -> flags { copyDest = v }) (reqArg' "DIR" (Flag . CopyPrefix) (\f -> case f of Flag (CopyPrefix p) -> [p]; _ -> [])) @@ -620,17 +657,17 @@ instance Monoid CopyFlags where mempty = CopyFlags { - copyDest = NoCopyDest, - copyDest' = mempty, + copyDest = mempty, copyDistPref = mempty, - copyVerbose = normal, + copyUseWrapper = mempty, + copyInPlace = mempty, copyVerbosity = mempty } mappend a b = CopyFlags { - copyDest = fromFlagOrDefault (copyDest a) (copyDest' b), - copyDest' = combine copyDest', + copyDest = combine copyDest, copyDistPref = combine copyDistPref, - copyVerbose = fromFlagOrDefault (copyVerbose a) (copyVerbosity b), + copyUseWrapper = combine copyUseWrapper, + copyInPlace = combine copyInPlace, copyVerbosity = combine copyVerbosity } where combine field = field a `mappend` field b @@ -643,7 +680,8 @@ data InstallFlags = InstallFlags { installPackageDB :: Flag PackageDB, installDistPref :: Flag FilePath, - installVerbose :: Verbosity, + installUseWrapper :: Flag Bool, + installInPlace :: Flag Bool, installVerbosity :: Flag Verbosity } deriving Show @@ -652,7 +690,8 @@ defaultInstallFlags = InstallFlags { installPackageDB = NoFlag, installDistPref = Flag defaultDistPref, - installVerbose = normal, + installUseWrapper = Flag False, + installInPlace = Flag False, installVerbosity = Flag normal } @@ -665,11 +704,23 @@ "Unlike the copy command, install calls the register command.\n" ++ "If you want to install into a location that is not what was\n" ++ "specified in the configure step, use the copy command.\n" - options _ = + options showOrParseArgs = [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref installDistPref (\d flags -> flags { installDistPref = d }) + ,optionDistPref + installDistPref (\d flags -> flags { installDistPref = d }) + showOrParseArgs - ,option "" ["packageDB"] "" + ,option "" ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace (\v flags -> flags { installInPlace = v }) + trueArg + + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper (\v flags -> flags { installUseWrapper = v }) + (boolOpt [] []) + + ,option "" ["package-db"] "" installPackageDB (\v flags -> flags { installPackageDB = v }) (choiceOpt [ (Flag UserPackageDB, ([],["user"]), "upon configuration register this package in the user's local package database") @@ -684,13 +735,15 @@ mempty = InstallFlags{ installPackageDB = mempty, installDistPref = mempty, - installVerbose = normal, + installUseWrapper = mempty, + installInPlace = mempty, installVerbosity = mempty } mappend a b = InstallFlags{ installPackageDB = combine installPackageDB, installDistPref = combine installDistPref, - installVerbose = fromFlagOrDefault (installVerbose a) (installVerbosity b), + installUseWrapper = combine installUseWrapper, + installInPlace = combine installInPlace, installVerbosity = combine installVerbosity } where combine field = field a `mappend` field b @@ -703,7 +756,6 @@ data SDistFlags = SDistFlags { sDistSnapshot :: Flag Bool, sDistDistPref :: Flag FilePath, - sDistVerbose :: Verbosity, sDistVerbosity :: Flag Verbosity } deriving Show @@ -712,7 +764,6 @@ defaultSDistFlags = SDistFlags { sDistSnapshot = Flag False, sDistDistPref = Flag defaultDistPref, - sDistVerbose = normal, sDistVerbosity = Flag normal } @@ -722,9 +773,11 @@ name = "sdist" shortDesc = "Generate a source distribution file (.tar.gz)." longDesc = Nothing - options _ = + options showOrParseArgs = [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref sDistDistPref (\d flags -> flags { sDistDistPref = d }) + ,optionDistPref + sDistDistPref (\d flags -> flags { sDistDistPref = d }) + showOrParseArgs ,option "" ["snapshot"] "Produce a snapshot source distribution" @@ -739,13 +792,11 @@ mempty = SDistFlags { sDistSnapshot = mempty, sDistDistPref = mempty, - sDistVerbose = normal, sDistVerbosity = mempty } mappend a b = SDistFlags { sDistSnapshot = combine sDistSnapshot, sDistDistPref = combine sDistDistPref, - sDistVerbose = fromFlagOrDefault (sDistVerbose a) (sDistVerbosity b), sDistVerbosity = combine sDistVerbosity } where combine field = field a `mappend` field b @@ -762,7 +813,6 @@ regGenPkgConf :: Flag (Maybe FilePath), regInPlace :: Flag Bool, regDistPref :: Flag FilePath, - regVerbose :: Verbosity, regVerbosity :: Flag Verbosity } deriving Show @@ -774,7 +824,6 @@ regGenPkgConf = NoFlag, regInPlace = Flag False, regDistPref = Flag defaultDistPref, - regVerbose = normal, regVerbosity = Flag normal } @@ -784,9 +833,11 @@ name = "register" shortDesc = "Register this package with the compiler." longDesc = Nothing - options _ = + options showOrParseArgs = [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs ,option "" ["packageDB"] "" regPackageDB (\v flags -> flags { regPackageDB = v }) @@ -817,9 +868,11 @@ name = "unregister" shortDesc = "Unregister this package with the compiler." longDesc = Nothing - options _ = + options showOrParseArgs = [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs ,option "" ["user"] "" regPackageDB (\v flags -> flags { regPackageDB = v }) @@ -844,7 +897,6 @@ regGenPkgConf = mempty, regInPlace = mempty, regDistPref = mempty, - regVerbose = normal, regVerbosity = mempty } mappend a b = RegisterFlags { @@ -853,7 +905,6 @@ regGenPkgConf = combine regGenPkgConf, regInPlace = combine regInPlace, regDistPref = combine regDistPref, - regVerbose = fromFlagOrDefault (regVerbose a) (regVerbosity b), regVerbosity = combine regVerbosity } where combine field = field a `mappend` field b @@ -866,7 +917,6 @@ hscolourCSS :: Flag FilePath, hscolourExecutables :: Flag Bool, hscolourDistPref :: Flag FilePath, - hscolourVerbose :: Verbosity, hscolourVerbosity :: Flag Verbosity } deriving Show @@ -879,7 +929,6 @@ hscolourCSS = NoFlag, hscolourExecutables = Flag False, hscolourDistPref = Flag defaultDistPref, - hscolourVerbose = normal, hscolourVerbosity = Flag normal } @@ -888,14 +937,12 @@ hscolourCSS = mempty, hscolourExecutables = mempty, hscolourDistPref = mempty, - hscolourVerbose = normal, hscolourVerbosity = mempty } mappend a b = HscolourFlags { hscolourCSS = combine hscolourCSS, hscolourExecutables = combine hscolourExecutables, hscolourDistPref = combine hscolourDistPref, - hscolourVerbose = fromFlagOrDefault (hscolourVerbose a) (hscolourVerbosity b), hscolourVerbosity = combine hscolourVerbosity } where combine field = field a `mappend` field b @@ -906,9 +953,11 @@ name = "hscolour" shortDesc = "Generate HsColour colourised code, in HTML format." longDesc = Just (\_ -> "Requires hscolour.\n") - options _ = + options showOrParseArgs = [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + ,optionDistPref + hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + showOrParseArgs ,option "" ["executables"] "Run hscolour for Executables targets" @@ -926,6 +975,8 @@ -- ------------------------------------------------------------ data HaddockFlags = HaddockFlags { + haddockProgramPaths :: [(String, FilePath)], + haddockProgramArgs :: [(String, [String])], haddockHoogle :: Flag Bool, haddockHtmlLocation :: Flag String, haddockExecutables :: Flag Bool, @@ -934,13 +985,14 @@ haddockHscolour :: Flag Bool, haddockHscolourCss :: Flag FilePath, haddockDistPref :: Flag FilePath, - haddockVerbose :: Verbosity, haddockVerbosity :: Flag Verbosity } deriving Show defaultHaddockFlags :: HaddockFlags defaultHaddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = [], haddockHoogle = Flag False, haddockHtmlLocation = NoFlag, haddockExecutables = Flag False, @@ -949,7 +1001,6 @@ haddockHscolour = Flag False, haddockHscolourCss = NoFlag, haddockDistPref = Flag defaultDistPref, - haddockVerbose = normal, haddockVerbosity = Flag normal } @@ -958,10 +1009,12 @@ where name = "haddock" shortDesc = "Generate Haddock HTML documentation." - longDesc = Just (\_ -> "Requires cpphs and haddock.\n") - options _ = + longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n" + options showOrParseArgs = [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref haddockDistPref (\d flags -> flags { haddockDistPref = d }) + ,optionDistPref + haddockDistPref (\d flags -> flags { haddockDistPref = d }) + showOrParseArgs ,option "" ["hoogle"] "Generate a hoogle database" @@ -998,12 +1051,20 @@ haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) (reqArgFlag "PATH") ] + ++ programConfigurationPaths progConf ParseArgs + haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) + ++ programConfigurationOptions progConf ParseArgs + haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) + progConf = addKnownProgram haddockProgram + emptyProgramConfiguration emptyHaddockFlags :: HaddockFlags emptyHaddockFlags = mempty instance Monoid HaddockFlags where mempty = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = mempty, haddockHoogle = mempty, haddockHtmlLocation = mempty, haddockExecutables = mempty, @@ -1012,10 +1073,11 @@ haddockHscolour = mempty, haddockHscolourCss = mempty, haddockDistPref = mempty, - haddockVerbose = normal, haddockVerbosity = mempty } mappend a b = HaddockFlags { + haddockProgramPaths = combine haddockProgramPaths, + haddockProgramArgs = combine haddockProgramArgs, haddockHoogle = combine haddockHoogle, haddockHtmlLocation = combine haddockHtmlLocation, haddockExecutables = combine haddockExecutables, @@ -1024,7 +1086,6 @@ haddockHscolour = combine haddockHscolour, haddockHscolourCss = combine haddockHscolourCss, haddockDistPref = combine haddockDistPref, - haddockVerbose = fromFlagOrDefault (haddockVerbose a) (haddockVerbosity b), haddockVerbosity = combine haddockVerbosity } where combine field = field a `mappend` field b @@ -1036,7 +1097,6 @@ data CleanFlags = CleanFlags { cleanSaveConf :: Flag Bool, cleanDistPref :: Flag FilePath, - cleanVerbose :: Verbosity, cleanVerbosity :: Flag Verbosity } deriving Show @@ -1045,7 +1105,6 @@ defaultCleanFlags = CleanFlags { cleanSaveConf = Flag False, cleanDistPref = Flag defaultDistPref, - cleanVerbose = normal, cleanVerbosity = Flag normal } @@ -1055,9 +1114,11 @@ name = "clean" shortDesc = "Clean up after a build." longDesc = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n") - options _ = + options showOrParseArgs = [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref cleanDistPref (\d flags -> flags { cleanDistPref = d }) + ,optionDistPref + cleanDistPref (\d flags -> flags { cleanDistPref = d }) + showOrParseArgs ,option "s" ["save-configure"] "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." @@ -1072,13 +1133,11 @@ mempty = CleanFlags { cleanSaveConf = mempty, cleanDistPref = mempty, - cleanVerbose = normal, cleanVerbosity = mempty } mappend a b = CleanFlags { cleanSaveConf = combine cleanSaveConf, cleanDistPref = combine cleanDistPref, - cleanVerbose = fromFlagOrDefault (cleanVerbose a) (cleanVerbosity b), cleanVerbosity = combine cleanVerbosity } where combine field = field a `mappend` field b @@ -1088,18 +1147,22 @@ -- ------------------------------------------------------------ data BuildFlags = BuildFlags { + buildProgramPaths :: [(String, FilePath)], buildProgramArgs :: [(String, [String])], buildDistPref :: Flag FilePath, - buildVerbose :: Verbosity, buildVerbosity :: Flag Verbosity } deriving Show +{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} +buildVerbose :: BuildFlags -> Verbosity +buildVerbose = fromFlagOrDefault normal . buildVerbosity + defaultBuildFlags :: BuildFlags defaultBuildFlags = BuildFlags { + buildProgramPaths = mempty, buildProgramArgs = [], buildDistPref = Flag defaultDistPref, - buildVerbose = normal, buildVerbosity = Flag normal } @@ -1111,9 +1174,14 @@ longDesc = Nothing options showOrParseArgs = optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) - : optionDistPref buildDistPref (\d flags -> flags { buildDistPref = d }) + : optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) + showOrParseArgs - : programConfigurationOptions progConf showOrParseArgs + : programConfigurationPaths progConf showOrParseArgs + buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) + + ++ programConfigurationOptions progConf showOrParseArgs buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) emptyBuildFlags :: BuildFlags @@ -1121,14 +1189,14 @@ instance Monoid BuildFlags where mempty = BuildFlags { + buildProgramPaths = mempty, buildProgramArgs = mempty, - buildVerbose = normal, - buildVerbosity = Flag normal, + buildVerbosity = mempty, buildDistPref = mempty } mappend a b = BuildFlags { + buildProgramPaths = combine buildProgramPaths, buildProgramArgs = combine buildProgramArgs, - buildVerbose = fromFlagOrDefault (buildVerbose a) (buildVerbosity b), buildVerbosity = combine buildVerbosity, buildDistPref = combine buildDistPref } @@ -1141,7 +1209,6 @@ data MakefileFlags = MakefileFlags { makefileFile :: Flag FilePath, makefileDistPref :: Flag FilePath, - makefileVerbose :: Verbosity, makefileVerbosity :: Flag Verbosity } deriving Show @@ -1150,7 +1217,6 @@ defaultMakefileFlags = MakefileFlags { makefileFile = NoFlag, makefileDistPref = Flag defaultDistPref, - makefileVerbose = normal, makefileVerbosity = Flag normal } @@ -1160,9 +1226,11 @@ name = "makefile" shortDesc = "Generate a makefile (only for GHC libraries)." longDesc = Nothing - options _ = + options showOrParseArgs = [optionVerbosity makefileVerbosity (\v flags -> flags { makefileVerbosity = v }) - ,optionDistPref makefileDistPref (\d flags -> flags { makefileDistPref = d }) + ,optionDistPref + makefileDistPref (\d flags -> flags { makefileDistPref = d }) + showOrParseArgs ,option "f" ["file"] "Filename to use (default: Makefile)." @@ -1177,13 +1245,11 @@ mempty = MakefileFlags { makefileFile = mempty, makefileDistPref = mempty, - makefileVerbose = normal, makefileVerbosity = mempty } mappend a b = MakefileFlags { makefileFile = combine makefileFile, makefileDistPref = combine makefileDistPref, - makefileVerbose = fromFlagOrDefault (makefileVerbose a) (makefileVerbosity b), makefileVerbosity = combine makefileVerbosity } where combine field = field a `mappend` field b @@ -1210,9 +1276,11 @@ name = "test" shortDesc = "Run the test suite, if any (configure with UserHooks)." longDesc = Nothing - options _ = + options showOrParseArgs = [optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - ,optionDistPref testDistPref (\d flags -> flags { testDistPref = d }) + ,optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs ] emptyTestFlags :: TestFlags @@ -1286,8 +1354,8 @@ get set (reqArg' "OPT" (\arg -> [(prog, [arg])]) (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) - + -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ @@ -1309,13 +1377,17 @@ optionDistPref :: (flags -> Flag FilePath) -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs -> OptionField flags -optionDistPref get set = - option "" ["distpref"] - ( "Control which directory Cabal puts its generated files in " +optionDistPref get set = \showOrParseArgs -> + option "" (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " ++ "(default " ++ defaultDistPref ++ ")") get set (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] optionVerbosity :: (flags -> Flag Verbosity) -> (Flag Verbosity -> flags -> flags) @@ -1352,7 +1424,7 @@ hc_flag_name --TODO kill off thic bc hack when defaultUserHooks is removed. | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" + | otherwise = "--with-compiler=" optFlag name config_field = case config_field flags of Flag p -> ["--" ++ name ++ "=" ++ p] NoFlag -> [] diff --git a/Distribution/Simple/SetupWrapper.hs b/Distribution/Simple/SetupWrapper.hs deleted file mode 100644 --- a/Distribution/Simple/SetupWrapper.hs +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.SetupWrapper --- Copyright : (c) The University of Glasgow 2006 --- --- Maintainer : http://hackage.haskell.org/trac/hackage --- Stability : alpha --- Portability : portable --- --- The user interface to building and installing Cabal packages. --- If the @Built-Type@ field is specified as something other than --- 'Custom', and the current version of Cabal is acceptable, this performs --- setup actions directly. Otherwise it builds the setup script and --- runs it with the given arguments. - -module Distribution.Simple.SetupWrapper (setupWrapper) where - -import qualified Distribution.Make as Make -import Distribution.Simple -import Distribution.Simple.Utils -import Distribution.Simple.Configure - ( configCompiler, getInstalledPackages, - configDependency ) -import Distribution.PackageDescription - ( PackageDescription(..), GenericPackageDescription(..), BuildType(..) - , readPackageDescription ) -import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Program ( ProgramConfiguration, - emptyProgramConfiguration, - rawSystemProgramConf, ghcProgram ) -import Distribution.Simple.GHC (ghcVerbosityOptions) -import Distribution.Text - ( display ) -import Distribution.GetOpt -import Distribution.ReadE -import System.Directory -import Distribution.Verbosity -import System.FilePath ((), (<.>)) -import Control.Monad ( when, unless ) -import Data.Maybe ( fromMaybe ) -import Data.Monoid ( Monoid(mempty) ) - - -- read the .cabal file - -- - attempt to find the version of Cabal required - - -- if the Cabal file specifies the build type (not Custom), - -- - behave like a boilerplate Setup.hs of that type - -- otherwise, - -- - if we find GHC, - -- - build the Setup script with the right version of Cabal - -- - invoke it with args - -- - if we find runhaskell (TODO) - -- - use runhaskell to invoke it - -- - -- Later: - -- - add support for multiple packages, by figuring out - -- dependencies here and building/installing the sub packages - -- in the right order. -setupWrapper :: - FilePath -- ^ "dist" prefix - -> [String] -- ^ Command-line arguments. - -> Maybe FilePath -- ^ Directory to run in. If 'Nothing', the current directory is used. - -> IO () -setupWrapper distPref args mdir = inDir mdir $ do - let (flag_fn, _, _, errs) = getOpt' Permute opts args - when (not (null errs)) $ die (unlines errs) - let Flags { withCompiler = hc, withHcPkg = hcPkg, withVerbosity = verbosity - } = foldr (.) id flag_fn defaultFlags - - pkg_descr_file <- defaultPackageDesc verbosity - ppkg_descr <- readPackageDescription verbosity pkg_descr_file - - let - setupDir = distPref "setup" - setupHs = setupDir "setup" <.> "hs" - setupProg = setupDir "setup" <.> exeExtension - trySetupScript f on_fail = do - b <- doesFileExist f - if not b then on_fail else do - hasSetup <- do b' <- doesFileExist setupProg - if not b' then return False else do - t1 <- getModificationTime f - t2 <- getModificationTime setupProg - return (t1 < t2) - unless hasSetup $ do - (comp, conf) <- configCompiler (Just GHC) hc hcPkg - emptyProgramConfiguration normal - let verRange = descCabalVersion (packageDescription ppkg_descr) - cabal_flag <- configCabalFlag verbosity verRange comp conf - createDirectoryIfMissingVerbose verbosity True setupDir - rawSystemProgramConf verbosity ghcProgram conf $ - cabal_flag - ++ ["--make", f, "-o", setupProg - ,"-odir", setupDir, "-hidir", setupDir] - ++ ghcVerbosityOptions verbosity - rawSystemExit verbosity setupProg args - - let buildType' = fromMaybe Custom (buildType (packageDescription ppkg_descr)) - case lookup buildType' buildTypes of - Just (mainAction, mainText) -> - if withinRange cabalVersion (descCabalVersion (packageDescription ppkg_descr)) - then mainAction args -- current version is OK, so no need - -- to compile a special Setup.hs. - else do createDirectoryIfMissingVerbose verbosity True setupDir - writeUTF8File setupHs mainText - trySetupScript setupHs $ error "panic! shouldn't happen" - Nothing -> - trySetupScript "Setup.hs" $ - trySetupScript "Setup.lhs" $ - die "no special Build-Type, but lacks Setup.hs or Setup.lhs" - -buildTypes :: [(BuildType, ([String] -> IO (), String))] -buildTypes = [ - (Simple, (defaultMainArgs, "import Distribution.Simple; main=defaultMain")), - (Configure, (defaultMainWithHooksArgs autoconfUserHooks, - "import Distribution.Simple; main=defaultMainWithHooks autoconfUserHooks")), - (Make, (Make.defaultMainArgs, "import Distribution.Make; main=defaultMain"))] - -data Flags - = Flags { - withCompiler :: Maybe FilePath, - withHcPkg :: Maybe FilePath, - withVerbosity :: Verbosity - } - -defaultFlags :: Flags -defaultFlags = Flags { - withCompiler = Nothing, - withHcPkg = Nothing, - withVerbosity = normal - } - -setWithCompiler :: Maybe FilePath -> Flags -> Flags -setWithCompiler f flags = flags{ withCompiler=f } - -setWithHcPkg :: Maybe FilePath -> Flags -> Flags -setWithHcPkg f flags = flags{ withHcPkg=f } - -setVerbosity :: Verbosity -> Flags -> Flags -setVerbosity v flags = flags{ withVerbosity=v } - -opts :: [OptDescr (Flags -> Flags)] -opts = [ - Option "w" ["with-setup-compiler"] (ReqArg (setWithCompiler.Just) "PATH") - "give the path to a particular compiler to use on setup", - Option "" ["with-setup-hc-pkg"] (ReqArg (setWithHcPkg.Just) "PATH") - "give the path to the package tool to use on setup", - Option "v" ["verbose"] (OptArg (maybe (setVerbosity verbose) - (setVerbosity . readEOrFail flagToVerbosity)) "n") - "Control verbosity (n is 0--3, default verbosity level is 1)" - ] - -configCabalFlag :: Verbosity -> VersionRange -> Compiler -> ProgramConfiguration -> IO [String] -configCabalFlag _ AnyVersion _ _ = return [] -configCabalFlag verbosity range comp conf = do - packageIndex <- fromMaybe mempty - `fmap` getInstalledPackages verbosity comp UserPackageDB conf - -- user packages are *allowed* here, no portability problem - cabal_pkgid <- configDependency verbosity packageIndex (Dependency "Cabal" range) - return ["-package", display cabal_pkgid] diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -2,14 +2,19 @@ -- | -- Module : Distribution.Simple.SrcDist -- Copyright : Simon Marlow 2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Implements the \"@.\/setup sdist@\" command, which creates a source --- distribution for this package. That is, packs up the source code --- into a tarball. +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. +-- The 'sdist' action now also does some distribution QA checks. {- Copyright (c) 2003-2004, Simon Marlow All rights reserved. @@ -56,6 +61,7 @@ -- ** Snaphots prepareSnapshotTree, + snapshotPackage, snapshotVersion, dateToSnapshotNumber, ) where @@ -63,14 +69,18 @@ import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) ) import Distribution.PackageDescription.Check + ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) import Distribution.Package - ( PackageIdentifier(pkgVersion), Package(..) ) + ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName import Distribution.Version ( Version(versionBranch), VersionRange(AnyVersion) ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File - , copyFiles, copyFileVerbose, findFile, findFileWithExtension - , withTempDirectory, dotToSep, defaultPackageDesc + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , copyFiles, copyFileVerbose + , findFile, findFileWithExtension, matchFileGlob + , withTempDirectory, defaultPackageDesc , die, warn, notice, setupMessage ) import Distribution.Simple.Setup (SDistFlags(..), fromFlag) import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources) @@ -116,14 +126,14 @@ withTempDirectory verbosity tmpDir $ do - setupMessage verbosity "Building source dist for" (packageId pkg) date <- toCalendarTime =<< getClockTime let pkg' | snapshot = snapshotPackage date pkg | otherwise = pkg + setupMessage verbosity "Building source dist for" (packageId pkg') + if snapshot - then getClockTime >>= toCalendarTime - >>= prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg mb_lbi distPref tmpDir pps + then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps + else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref notice verbosity $ "Source tarball created: " ++ targzFile @@ -140,7 +150,7 @@ -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) -> IO FilePath -- ^the name of the dir created and populated -prepareTree verbosity pkg_descr mb_lbi distPref tmpDir pps = do +prepareTree verbosity pkg_descr0 mb_lbi distPref tmpDir pps = do let targetDir = tmpDir tarBallName pkg_descr createDirectoryIfMissingVerbose verbosity True targetDir -- maybe move the library files into place @@ -156,15 +166,17 @@ Just pp -> return pp copyFileTo verbosity targetDir srcMainFile flip mapM_ (dataFiles pkg_descr) $ \ filename -> do - let file = dataDir pkg_descr filename - dir = takeDirectory file + files <- matchFileGlob (dataDir pkg_descr filename) + let dir = takeDirectory (dataDir pkg_descr filename) createDirectoryIfMissingVerbose verbosity True (targetDir dir) - copyFileVerbose verbosity file (targetDir file) + sequence_ [ copyFileVerbose verbosity file (targetDir file) + | file <- files ] when (not (null (licenseFile pkg_descr))) $ copyFileTo verbosity targetDir (licenseFile pkg_descr) flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do - copyFileTo verbosity targetDir fpath + files <- matchFileGlob fpath + sequence_ [ copyFileTo verbosity targetDir file | file <- files ] -- copy the install-include files withLib $ \ l -> do @@ -196,6 +208,12 @@ return targetDir where + pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 + filterAutogenModule bi = bi { + otherModules = filter (/=autogenModule) (otherModules bi) + } + autogenModule = autogenModuleName pkg_descr0 + findInc [] f = die ("can't find include file " ++ f) findInc (d:ds) f = do let path = (d f) @@ -207,8 +225,9 @@ withLib action = maybe (return ()) action (library pkg_descr) withExe action = mapM_ action (executables pkg_descr) --- | Prepare a directory tree of source files for a snapshot version with the --- given date. +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. -- prepareSnapshotTree :: Verbosity -- ^verbosity -> PackageDescription -- ^info from the cabal file @@ -216,24 +235,20 @@ -> FilePath -- ^dist dir -> FilePath -- ^source tree to populate -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> CalendarTime -- ^snapshot date -> IO FilePath -- ^the resulting temp dir -prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps date = do - let pkgid = packageId pkg - pkgver' = snapshotVersion date (pkgVersion pkgid) - pkg' = pkg { package = pkgid { pkgVersion = pkgver' } } - targetDir <- prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - overwriteSnapshotPackageDesc pkgver' targetDir +prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps = do + targetDir <- prepareTree verbosity pkg mb_lbi distPref tmpDir pps + overwriteSnapshotPackageDesc (packageVersion pkg) targetDir return targetDir - + where overwriteSnapshotPackageDesc version targetDir = do -- We could just writePackageDescription targetDescFile pkg_descr, -- but that would lose comments and formatting. descFile <- defaultPackageDesc verbosity - writeUTF8File (targetDir descFile) + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) . unlines . map (replaceVersion version) . lines - =<< readUTF8File descFile replaceVersion :: Version -> String -> String replaceVersion version line @@ -299,23 +314,18 @@ -> FilePath -- ^dist dir -> FilePath -- ^TargetPrefix -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> [String] -- ^Exposed modules + -> [ModuleName] -- ^Exposed modules -> BuildInfo -> IO () -prepareDir verbosity pkg distPref inPref pps modules bi - = do let searchDirs = hsSourceDirs bi ++ [autogenModulesDir] - autogenModulesDir = distPref "build" "autogen" - autogenFile = autogenModulesDir autogenModuleName pkg <.> "hs" - -- the Paths_$pkgname module might be in the modules list. If it - -- turns out that resolves to the actual autogen file then we filter - -- it out because we do not want to put it into the tarball. - sources <- filter (/=autogenFile) `fmap` sequence - [ let file = dotToSep module_ +prepareDir verbosity _pkg _distPref inPref pps modules bi + = do let searchDirs = hsSourceDirs bi + sources <- sequence + [ let file = ModuleName.toFilePath module_ in findFileWithExtension suffixes searchDirs file >>= maybe (notFound module_) return | module_ <- modules ++ otherModules bi ] bootFiles <- sequence - [ let file = dotToSep module_ + [ let file = ModuleName.toFilePath module_ in findFileWithExtension ["hs-boot"] (hsSourceDirs bi) file | module_ <- modules ++ otherModules bi ] @@ -323,7 +333,7 @@ copyFiles verbosity inPref (zip (repeat []) allSources) where suffixes = ppSuffixes pps ++ ["hs", "lhs"] - notFound m = die $ "Error: Could not find module: " ++ m + notFound m = die $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show suffixes copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () @@ -344,10 +354,10 @@ ++ unlines (map explanation errors) unless (null warnings) $ notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map explanation warnings) + ++ unlines (map explanation warnings) unless (null errors) $ notice verbosity - "Note: the public hackage server would reject this package." + "Note: the public hackage server would reject this package." ------------------------------------------------------------ @@ -355,3 +365,13 @@ -- tarBallName :: PackageDescription -> String tarBallName = display . packageId + +mapAllBuildInfo :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = pkg { + library = fmap mapLibBi (library pkg), + executables = fmap mapExeBi (executables pkg) + } + where + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs --- a/Distribution/Simple/UserHooks.hs +++ b/Distribution/Simple/UserHooks.hs @@ -2,19 +2,25 @@ -- | -- Module : Distribution.Simple.UserHooks -- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Simple build system; basically the interface for --- Distribution.Simple.\* modules. When given the parsed command-line --- args and package information, is able to perform basic commands --- like configure, build, install, register, etc. +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. -- --- This module isn't called \"Simple\" because it's simple. Far from --- it. It's called \"Simple\" because it does complicated things to --- simple software. +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- various phases because it would involve changing the types of the +-- corresponding hook. At some point it will have to be replaced. {- All rights reserved. diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -9,13 +9,15 @@ -- Module : Distribution.Simple.Utils -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Explanation: Misc. Utilities, especially file-related utilities. --- Stuff used by multiple modules that doesn't fit elsewhere. +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. {- All rights reserved. @@ -56,15 +58,13 @@ dieWithLocation, warn, notice, setupMessage, info, debug, chattyTry, - breaks, -- * running programs rawSystemExit, rawSystemStdout, - rawSystemStdout', + rawSystemStdout', maybeExit, xargs, - inDir, -- * copying files smartCopySources, @@ -75,13 +75,16 @@ -- * file names currentDir, - dotToSep, -- * finding files - findFile, + findFile, findFileWithExtension, findFileWithExtension', + -- * simple file globbing + matchFileGlob, + matchDirFileGlob, + -- * temp files and dirs withTempFile, withTempDirectory, @@ -89,12 +92,13 @@ -- * .cabal and .buildinfo files defaultPackageDesc, findPackageDesc, - defaultHookedPackageDesc, - findHookedPackageDesc, + defaultHookedPackageDesc, + findHookedPackageDesc, -- * reading and writing files safely withFileContents, writeFileAtomic, + rewriteFile, -- * Unicode fromUTF8, @@ -123,8 +127,7 @@ ( Bits((.|.), (.&.), shiftL, shiftR) ) import System.Directory - ( getDirectoryContents, getCurrentDirectory, setCurrentDirectory, doesDirectoryExist - , doesFileExist, removeFile ) + ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile ) import System.Environment ( getProgName ) import System.Cmd @@ -132,35 +135,42 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath - ( takeDirectory, splitFileName, splitExtension, normalise - , (), (<.>), pathSeparator ) + ( normalise, (), (<.>), takeDirectory, splitFileName + , splitExtension, splitExtensions ) import System.Directory ( copyFile, createDirectoryIfMissing, renameFile, removeDirectoryRecursive ) import System.IO ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error - ( try ) + ( try, isDoesNotExistError ) import qualified Control.Exception as Exception - ( bracket, bracket_, catch, handle, finally, throwIO ) import Distribution.Text ( display ) import Distribution.Package ( PackageIdentifier ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName import Distribution.Version (Version(..)) +import Control.Exception (evaluate) + #ifdef __GLASGOW_HASKELL__ import Control.Concurrent (forkIO) -import Control.Exception (evaluate) import System.Process (runInteractiveProcess, waitForProcess) #else import System.Cmd (system) import System.Directory (getTemporaryDirectory) #endif -import Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) +import Distribution.Compat.TempFile (openTempFile, + openNewBinaryFile) +import Distribution.Compat.Exception (catchIO, onException) +#if mingw32_HOST_OS || mingw32_TARGET_OS +import Distribution.Compat.Exception (throwIOIO) +#endif import Distribution.Verbosity -- We only get our own version number when we're building with ourselves @@ -198,7 +208,7 @@ -- We display these at the 'normal' verbosity level. -- warn :: Verbosity -> String -> IO () -warn verbosity msg = +warn verbosity msg = when (verbosity >= normal) $ do hFlush stdout hPutStr stderr (wrapText ("Warning: " ++ msg)) @@ -220,7 +230,7 @@ notice verbosity (msg ++ ' ': display pkgid ++ "...") -- | More detail on the operation of some action. --- +-- -- We display these messages when the verbosity level is 'verbose' -- info :: Verbosity -> String -> IO () @@ -234,8 +244,9 @@ -- debug :: Verbosity -> String -> IO () debug verbosity msg = - when (verbosity >= deafening) $ + when (verbosity >= deafening) $ do putStr (wrapText msg) + hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. @@ -243,20 +254,12 @@ -> IO () -- ^ the action itself -> IO () chattyTry desc action = - Exception.catch action $ \exception -> + catchIO action $ \exception -> putStrLn $ "Error while " ++ desc ++ ": " ++ show exception -- ----------------------------------------------------------------------------- -- Helper functions -breaks :: (a -> Bool) -> [a] -> [[a]] -breaks _ [] = [] -breaks f xs = case span f xs of - (_, xs') -> - case break f xs' of - (v, xs'') -> - v : breaks f xs'' - -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String wrapText = unlines @@ -332,7 +335,7 @@ -- NB. do the hGetContents synchronously, otherwise the outer -- bracket can exit before this thread has run, and hGetContents -- will fail. - err <- hGetContents errh + err <- hGetContents errh forkIO $ do evaluate (length err); return () -- wait for all the output @@ -364,7 +367,7 @@ -- need to invoke a command multiple times to get all the args in. -- -- Use it with either of the rawSystem variants above. For example: --- +-- -- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs -- xargs :: Int -> ([String] -> IO ()) @@ -384,14 +387,6 @@ | otherwise = (reverse acc, s:ss) where len' = length s --- | Executes the action in the specified directory. -inDir :: Maybe FilePath -> IO () -> IO () -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old - -- ------------------------------------------------------------ -- * File Utilities -- ------------------------------------------------------------ @@ -433,12 +428,45 @@ then return (Just x) else findFirst xs -dotToSep :: String -> String -dotToSep = map dts - where - dts '.' = pathSeparator - dts c = c +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String + +parseFileGlob :: FilePath -> Maybe FileGlob +parseFileGlob filepath = case splitExtensions filepath of + (filepath', ext) -> case splitFileName filepath' of + (dir, "*") | '*' `elem` dir + || '*' `elem` ext + || null ext -> Nothing + | null dir -> Just (FileGlob "." ext) + | otherwise -> Just (FileGlob dir ext) + _ | '*' `elem` filepath -> Nothing + | otherwise -> Just (NoGlob filepath) + +matchFileGlob :: FilePath -> IO [FilePath] +matchFileGlob = matchDirFileGlob "." + +matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob dir filepath = case parseFileGlob filepath of + Nothing -> die $ "invalid filepath '" ++ filepath + ++ "'. Wildcards '*' are only allowed in place of the file" + ++ " name, not in the directory name or file extension." + ++ " If a wildcard is used it must be with an file extension." + Just (NoGlob filepath') -> return [filepath'] + Just (FileGlob dir' ext) -> do + files <- getDirectoryContents (dir dir') + case [ dir' file + | file <- files + , let (name, ext') = splitExtensions file + , not (null name) && ext' == ext ] of + [] -> die $ "filepath wildcard '" ++ filepath + ++ "' does not match any files." + matches -> return matches + -- |Copy the source files into the right directory. Looks in the -- build prefix for files that look like the input modules, based on -- the input search suffixes. It copies the files into the target @@ -447,16 +475,16 @@ smartCopySources :: Verbosity -- ^verbosity -> [FilePath] -- ^build prefix (location of objects) -> FilePath -- ^Target directory - -> [String] -- ^Modules + -> [ModuleName] -- ^Modules -> [String] -- ^search suffixes -> IO () smartCopySources verbosity srcDirs targetDir sources searchSuffixes = mapM moduleToFPErr sources >>= copyFiles verbosity targetDir where moduleToFPErr m - = findFileWithExtension' searchSuffixes srcDirs (dotToSep m) + = findFileWithExtension' searchSuffixes srcDirs (ModuleName.toFilePath m) >>= maybe notFound return - where notFound = die $ "Error: Could not find module: " ++ m + where notFound = die $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show searchSuffixes createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO () @@ -582,16 +610,13 @@ -- writeFileAtomic :: FilePath -> String -> IO () writeFileAtomic targetFile content = do - (tmpFile, tmpHandle) <- openBinaryTempFile targetDir template - Exception.handle (\err -> do hClose tmpHandle - removeFile tmpFile - Exception.throwIO err) $ do - hPutStr tmpHandle content + (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template + do hPutStr tmpHandle content hClose tmpHandle #if mingw32_HOST_OS || mingw32_TARGET_OS renameFile tmpFile targetFile -- If the targetFile exists then renameFile will fail - `Exception.catch` \err -> do + `catchIO` \err -> do exists <- doesFileExist targetFile if exists then do removeFile targetFile @@ -599,10 +624,12 @@ renameFile tmpFile targetFile -- If the removeFile succeeds and the renameFile fails -- then we've lost the atomic property. - else Exception.throwIO err + else throwIOIO err #else renameFile tmpFile targetFile #endif + `onException` do hClose tmpHandle + removeFile tmpFile where template = targetName <.> "tmp" targetDir | null targetDir_ = currentDir @@ -611,6 +638,20 @@ -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catch mightNotExist $ do + existingContent <- readFile path + evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFileAtomic path newContent + where + mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent + | otherwise = ioError e -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific. @@ -661,8 +702,8 @@ -- |Find auxiliary package information in the given directory. -- Looks for @.buildinfo@ files. findHookedPackageDesc - :: FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present + :: FilePath -- ^Directory to search + -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc dir = do files <- getDirectoryContents dir buildInfoFiles <- filterM doesFileExist @@ -671,9 +712,9 @@ , let (name, ext) = splitExtension file , not (null name) && ext == buildInfoExt ] case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die ("Multiple files with extension " ++ buildInfoExt) + [] -> return Nothing + [f] -> return (Just f) + _ -> die ("Multiple files with extension " ++ buildInfoExt) buildInfoExt :: String buildInfoExt = ".buildinfo" diff --git a/Distribution/System.hs b/Distribution/System.hs --- a/Distribution/System.hs +++ b/Distribution/System.hs @@ -1,3 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.System +-- Copyright : Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Cabal often needs to do slightly different things on specific platforms. You +-- probably know about the 'System.Info.os' however using that is very +-- inconvenient because it is a string and different Haskell implementations +-- do not agree on using the same strings for the same platforms! (In +-- particular see the controversy over "windows" vs "ming32"). So to make it +-- more consistent and easy to use we have an 'OS' enumeration. +-- module Distribution.System ( -- * Operating System OS(..), @@ -6,6 +21,10 @@ -- * Machine Architecture Arch(..), buildArch, + + -- * Platform is a pair of arch and OS + Platform(..), + buildPlatform, ) where import qualified System.Info (os, arch) @@ -14,6 +33,7 @@ import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) -- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. -- @@ -82,7 +102,7 @@ data Arch = I386 | X86_64 | PPC | PPC64 | Sparc | Arm | Mips | SH - | IA64 | S390 + | IA64 | S390 | Alpha | Hppa | Rs6000 | M68k | Vax | OtherArch String @@ -91,7 +111,7 @@ knownArches :: [Arch] knownArches = [I386, X86_64, PPC, PPC64, Sparc ,Arm, Mips, SH - ,IA64, S390 + ,IA64, S390 ,Alpha, Hppa, Rs6000 ,M68k, Vax] @@ -123,6 +143,26 @@ buildArch :: Arch buildArch = classifyArch Permissive System.Info.arch + +-- ------------------------------------------------------------ +-- * Platform +-- ------------------------------------------------------------ + +data Platform = Platform Arch OS + deriving (Eq, Ord, Show, Read) + +instance Text Platform where + disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os + parse = do + arch <- parse + Parse.char '-' + os <- parse + return (Platform arch os) + +buildPlatform :: Platform +buildPlatform = Platform buildArch buildOS + +-- Utils: ident :: Parse.ReadP r String ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') diff --git a/Distribution/Text.hs b/Distribution/Text.hs --- a/Distribution/Text.hs +++ b/Distribution/Text.hs @@ -1,3 +1,16 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Text +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'Text' class which is a bit like the 'Read' and 'Show' +-- classes. The difference is that is uses a modern pretty printer and parser +-- system and the format is not expected to be Haskell concrete syntax but +-- rather the external human readable representation used by Cabal. +-- module Distribution.Text ( Text(..), display, @@ -15,7 +28,12 @@ parse :: Parse.ReadP r a display :: Text a => a -> String -display = Disp.render . disp +display = Disp.renderStyle style . disp + where style = Disp.Style { + Disp.mode = Disp.PageMode, + Disp.lineLength = 79, + Disp.ribbonsPerLine = 1.0 + } simpleParse :: Text a => String -> Maybe a simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs --- a/Distribution/Verbosity.hs +++ b/Distribution/Verbosity.hs @@ -3,10 +3,13 @@ -- Module : Distribution.Verbosity -- Copyright : Ian Lynagh 2007 -- --- Maintainer : Isaac Jones --- Stability : alpha +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- +-- A simple 'Verbosity' type with associated utilities. There are 4 standard +-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This +-- is used for deciding what logging messages to print. + -- Verbosity for Cabal functions {- Copyright (c) 2007, Ian Lynagh diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -2,12 +2,13 @@ -- | -- Module : Distribution.Version -- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- Versions for packages, based on the 'Version' datatype. +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data +-- types. Version ranges are like @\">= 1.2 && < 2\"@. {- Copyright (c) 2003-2004, Isaac Jones All rights reserved. @@ -51,18 +52,16 @@ withinRange, isAnyVersion, - -- * Deprecated compat stuff - showVersion, - parseVersion, ) where -import Data.Version ( Version(..) ) +import Data.Version ( Version(..) ) -import Distribution.Text ( Text(..), display ) +import Distribution.Text ( Text(..) ) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((+++)) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) +import qualified Data.Char as Char (isDigit) -- ----------------------------------------------------------------------------- -- Version ranges @@ -72,10 +71,10 @@ data VersionRange = AnyVersion - | ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | EarlierVersion Version -- < version - -- ToDo: are these too general? + | ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | EarlierVersion Version -- < version + -- ToDo: are these too general? | UnionVersionRanges VersionRange VersionRange | IntersectVersionRanges VersionRange VersionRange deriving (Show,Read,Eq) @@ -107,12 +106,12 @@ -- |Does this version fall within the given range? withinRange :: Version -> VersionRange -> Bool withinRange _ AnyVersion = True -withinRange v1 (ThisVersion v2) = v1 == v2 +withinRange v1 (ThisVersion v2) = v1 == v2 withinRange v1 (LaterVersion v2) = v1 `laterVersion` v2 withinRange v1 (EarlierVersion v2) = v1 `earlierVersion` v2 -withinRange v1 (UnionVersionRanges v2 v3) +withinRange v1 (UnionVersionRanges v2 v3) = v1 `withinRange` v2 || v1 `withinRange` v3 -withinRange v1 (IntersectVersionRanges v2 v3) +withinRange v1 (IntersectVersionRanges v2 v3) = v1 `withinRange` v2 && v1 `withinRange` v3 instance Text VersionRange where @@ -130,6 +129,11 @@ | v1 == v2 = Disp.text "<=" <> disp v1 disp (UnionVersionRanges r1 r2) = disp r1 <+> Disp.text "||" <+> disp r2 + disp (IntersectVersionRanges + (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) + (EarlierVersion v3)) + | v1 == v2 && isWildcardRange (versionBranch v1) (versionBranch v3) + = Disp.text "==" <> disp (VersionWildcard (versionBranch v1)) disp (IntersectVersionRanges r1 r2) = disp r1 <+> Disp.text "&&" <+> disp r2 @@ -142,16 +146,20 @@ f2 <- factor return (UnionVersionRanges f1 f2) +++ - do + do Parse.string "&&" Parse.skipSpaces f2 <- factor return (IntersectVersionRanges f1 f2) +++ return f1) - where - factor = Parse.choice ((Parse.string "-any" >> return AnyVersion) : - map parseRangeOp rangeOps) + where + factor = Parse.choice $ parseAnyVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + parseWildcardRange = Parse.string "==" >> Parse.skipSpaces + >> fmap wildcardRange parse parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse rangeOps = [ ("<", EarlierVersion), ("<=", orEarlierVersion), @@ -159,13 +167,35 @@ (">=", orLaterVersion), ("==", ThisVersion) ] --- --------------------------------------------------------------------------- --- Deprecated compat stuff +newtype VersionWildcard = VersionWildcard [Int] -{-# DEPRECATED showVersion "use the Text class instead" #-} -showVersion :: Version -> String -showVersion = display +instance Text VersionWildcard where + disp (VersionWildcard branch) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + <> Disp.text ".*" + parse = do + branch <- Parse.sepBy1 digits (Parse.char '.') + Parse.char '.' + Parse.char '*' + return (VersionWildcard branch) + where + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) -{-# DEPRECATED parseVersion "use the Text class instead" #-} -parseVersion :: Parse.ReadP r Version -parseVersion = parse +-- | @x.y.*@ becomes @>= x.y && < x.(y+1)@ +wildcardRange :: VersionWildcard -> VersionRange +wildcardRange (VersionWildcard branch) = orLaterVersion lowerBound + `IntersectVersionRanges` EarlierVersion upperBound + where + lowerBound = Version branch [] + upperBound = Version (init branch ++ [last branch + 1]) [] + +-- | isWildcardRange [x,y] [x,y+1] = True +isWildcardRange :: [Int] -> [Int] -> Bool +isWildcardRange (n:[]) (m:[]) | n+1 == m = True +isWildcardRange (n:ns) (m:ms) | n == m = isWildcardRange ns ms +isWildcardRange _ _ = False diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -2,9 +2,8 @@ -- | -- Module : Language.Haskell.Extension -- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha +-- +-- Maintainer : libraries@haskell.org -- Portability : portable -- -- Haskell language extensions @@ -40,7 +39,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Language.Haskell.Extension ( - Extension(..), + Extension(..), knownExtensions ) where @@ -125,6 +124,12 @@ | DeriveDataTypeable | ConstrainedClassMethods + -- | Allow imports to be qualified by the package name that the module + -- is intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + | PackageImports + | UnknownExtension String deriving (Show, Read, Eq) @@ -185,6 +190,7 @@ , UnboxedTuples , DeriveDataTypeable , ConstrainedClassMethods + , PackageImports ] instance Text Extension where diff --git a/README b/README --- a/README +++ b/README @@ -1,12 +1,15 @@ -[Cabal home page](http://www.haskell.org/cabal/) +The Cabal library package +========================= -Installation instructions for the Cabal library -=============================================== +[Cabal home page](http://www.haskell.org/cabal/) If you also want the `cabal` command line program then you need the `cabal-install` package in addition to this library. +Installation instructions for the Cabal library +=============================================== + Installing as a user (no root or administer access) --------------------------------------------------- @@ -17,6 +20,9 @@ Note the use of the `--user` flag at the configure step. +Compiling Setup rather than using `runghc Setup` is much faster and works on +Windows. For all packages other than Cabal itself it is fine to use `runghc`. + This will install into `$HOME/.cabal/` on unix and into `$Documents and Settings\$User\Application Data\cabal\` on Windows If you want to install elsewhere use the `--prefix=` flag at the @@ -31,6 +37,9 @@ ./Setup build sudo ./Setup install +Compiling Setup rather than using `runghc Setup` is much faster and works on +Windows. For all packages other than Cabal itself it is fine to use `runghc`. + This will install into `/usr/local` on unix and on Windows it will install into `$ProgramFiles/Haskell`. If you want to install elsewhere use the `--prefix=` flag at the configure step. @@ -56,8 +65,55 @@ ghc-pkg unregister Cabal --user +The `filepath` dependency +========================= + +Cabal now uses the `filepath` package so that must be installed first. +GHC-6.6.1 and later come with `filepath` however earlier versions do not by +default. If you do not already have `filepath` then you need to install it. You +can use any existing version of Cabal to do that. If you have neither Cabal or +filepath then it is slightly harder but still possible. + +Unpack Cabal and filepath into separate directories. For example: + + tar -xzf filepath-1.1.0.0.tar.gz + tar -xzf Cabal-1.6.0.0.tar.gz + + # rename to make the following instructions simpler: + mv filepath-1.1.0.0/ filepath/ + mv Cabal-1.6.0.0/ Cabal/ + + cd Cabal + ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup + cd ../filepath/ + ./setup configure --user + ./setup build + ./setup install + +This installs filepath so you are then in a position to install Cabal by the +normal method. + + +More Information +================ + +Please see the web site for the [user guide] and API documentation. +There is some more information available on the [development wiki]. + +[user guide]: http://www.haskell.org/cabal/ +[development wiki]: http://hackage.haskell.org/trac/hackage/ + + +Bugs +======= + +Please report bugs and wish-list items in our [bug tracker]. + +[bug tracker]: http://hackage.haskell.org/trac/hackage/ + + Your Help -========= +--------- To help us in the next round of development work it would be enormously helpful to know from our users what their most pressing @@ -70,9 +126,7 @@ helpful if there is a description of how you would expect to interact with the new feature. -[bug tracker]: http://hackage.haskell.org/trac/hackage/ - Code ======= @@ -83,9 +137,9 @@ > darcs get --partial http://darcs.haskell.org/cabal -and you can get the stable 1.4 branch: +and you can get the stable 1.6 branch: -> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.4 +> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6 Credits diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,6 +1,24 @@ -*-change-log-*- -1.5.x (current development version) +1.6.0.0 Duncan Coutts October 2008 + * Support for ghc-6.10 + * Source control repositories can now be specified in .cabal files + * Bug report URLs can be now specified in .cabal files + * Wildcards now allowed in data-files and extra-source-files fields + * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" + * New cabal_macros.h provides macros to test versions of dependencies + * Relocatable bindists now possible on unix via env vars + * New 'exposed' field allows packages to be not exposed by default + * Install dir flags can now use $os and $arch variables + * New --builddir flag allows multiple builds from a single sources dir + * cc-options now only apply to .c files, not for -fvia-C + * cc-options are not longer propagated to dependent packages + * The cpp/cc/ld-options fields no longer use ',' as a separator + * hsc2hs is now called using gcc instead of using ghc as gcc + * New api for manipulating sets and graphs of packages + * Internal api improvements and code cleanups + * Minor improvements to the user guide + * Miscellaneous minor bug fixes 1.4.0.2 Duncan Coutts August 2008 * Fix executable stripping default