Cabal 1.4.0.2 → 1.6.0.1
raw patch · 57 files changed
+5376/−3584 lines, 57 filesdep ~arraydep ~basedep ~containers
Dependency ranges changed: array, base, containers
Files
- Cabal.cabal +35/−19
- Distribution/Compat/Exception.hs +51/−0
- Distribution/Compat/Permissions.hs +34/−0
- Distribution/Compat/ReadP.hs +11/−25
- Distribution/Compat/TempFile.hs +84/−2
- Distribution/Compiler.hs +16/−4
- Distribution/Extension.hs +0/−47
- Distribution/GetOpt.hs +21/−22
- Distribution/InstalledPackageInfo.hs +101/−114
- Distribution/License.hs +10/−9
- Distribution/Make.hs +41/−33
- Distribution/ModuleName.hs +91/−0
- Distribution/Package.hs +41/−39
- Distribution/PackageDescription.hs +681/−1326
- Distribution/PackageDescription/Check.hs +240/−42
- Distribution/PackageDescription/Configuration.hs +86/−31
- Distribution/PackageDescription/Parse.hs +879/−0
- Distribution/ParseUtils.hs +117/−75
- Distribution/ReadE.hs +2/−3
- Distribution/Setup.hs +0/−5
- Distribution/Simple.hs +107/−83
- Distribution/Simple/Build.hs +64/−237
- Distribution/Simple/Build/Macros.hs +55/−0
- Distribution/Simple/Build/PathsModule.hs +235/−0
- Distribution/Simple/BuildPaths.hs +11/−7
- Distribution/Simple/Command.hs +33/−22
- Distribution/Simple/Compiler.hs +15/−7
- Distribution/Simple/Configure.hs +109/−108
- Distribution/Simple/GHC.hs +416/−201
- Distribution/Simple/GHC/IPI641.hs +121/−0
- Distribution/Simple/GHC/IPI642.hs +158/−0
- Distribution/Simple/GHC/Makefile.hs +2/−2
- Distribution/Simple/GHC/Makefile.in +12/−46
- Distribution/Simple/Haddock.hs +41/−26
- Distribution/Simple/Hugs.hs +153/−144
- Distribution/Simple/Install.hs +39/−25
- Distribution/Simple/InstallDirs.hs +70/−35
- Distribution/Simple/JHC.hs +21/−20
- Distribution/Simple/LocalBuildInfo.hs +32/−42
- Distribution/Simple/NHC.hs +22/−13
- Distribution/Simple/PackageIndex.hs +138/−77
- Distribution/Simple/PreProcess.hs +135/−90
- Distribution/Simple/PreProcess/Unlit.hs +2/−3
- Distribution/Simple/Program.hs +145/−65
- Distribution/Simple/Register.hs +76/−60
- Distribution/Simple/Setup.hs +224/−152
- Distribution/Simple/SetupWrapper.hs +0/−160
- Distribution/Simple/SrcDist.hs +65/−45
- Distribution/Simple/UserHooks.hs +16/−10
- Distribution/Simple/Utils.hs +103/−62
- Distribution/System.hs +42/−2
- Distribution/Text.hs +19/−1
- Distribution/Verbosity.hs +5/−2
- Distribution/Version.hs +58/−28
- Language/Haskell/Extension.hs +10/−4
- README +62/−8
- changelog +19/−1
Cabal.cabal view
@@ -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 <duncan@haskell.org> 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
+ Distribution/Compat/Exception.hs view
@@ -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+
+ Distribution/Compat/Permissions.hs view
@@ -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
Distribution/Compat/ReadP.hs view
@@ -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
Distribution/Compat/TempFile.hs view
@@ -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
Distribution/Compiler.hs view
@@ -2,12 +2,24 @@ -- | -- Module : Distribution.Compiler -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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.
− Distribution/Extension.hs
@@ -1,47 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.Extension--- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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(..))
Distribution/GetOpt.hs view
@@ -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))
Distribution/InstalledPackageInfo.hs view
@@ -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
Distribution/License.hs view
@@ -2,18 +2,19 @@ -- | -- Module : Distribution.License -- Copyright : Isaac Jones 2003-2005--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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 <http://www.opensource.org/>. ----- 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
Distribution/Make.hs view
@@ -2,48 +2,56 @@ -- | -- Module : Distribution.Make -- Copyright : Martin Sjögren 2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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` \_ ->
+ Distribution/ModuleName.hs view
@@ -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
Distribution/Package.hs view
@@ -2,12 +2,14 @@ -- | -- Module : Distribution.Package -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/PackageDescription.hs view
@@ -2,1329 +2,684 @@ -- | -- Module : Distribution.PackageDescription -- Copyright : Isaac Jones 2003-2005--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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)
Distribution/PackageDescription/Check.hs view
@@ -3,11 +3,21 @@ -- Module : Distribution.PackageDescription.Check -- Copyright : Lennart Kolmodin 2008 ----- Maintainer : Lennart Kolmodin <kolmodin@gentoo.org>--- 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
Distribution/PackageDescription/Configuration.hs view
@@ -8,12 +8,15 @@ -- | -- Module : Distribution.Configuration -- Copyright : Thomas Schilling, 2007--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
+ Distribution/PackageDescription/Parse.hs view
@@ -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."
Distribution/ParseUtils.hs view
@@ -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 @<property>: <value>@ field | Section LineNo String String [Field] -- ^ A section with a name and possible parameter. The syntactic -- structure is:- -- + -- -- @ -- <sectionname> <arg> { -- <field>*@@ -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
Distribution/ReadE.hs view
@@ -3,8 +3,7 @@ -- Module : Distribution.ReadE -- Copyright : Jose Iborra 2008 ----- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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)
− Distribution/Setup.hs
@@ -1,5 +0,0 @@-module Distribution.Setup-{-# DEPRECATED "Use module Distribution.Simple.Setup instead" #-}- (module Distribution.Simple.Setup) where--import Distribution.Simple.Setup
Distribution/Simple.hs view
@@ -2,19 +2,27 @@ -- | -- Module : Distribution.Simple -- Copyright : Isaac Jones 2003-2005--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Simple/Build.hs view
@@ -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 <ijones@syntaxpolice.org>--- 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_<pkg>.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_<pkg>.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_<pkg>.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)
+ Distribution/Simple/Build/Macros.hs view
@@ -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_<package>(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+
+ Distribution/Simple/Build/PathsModule.hs view
@@ -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_<pkg>.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")
Distribution/Simple/BuildPaths.hs view
@@ -4,8 +4,7 @@ -- Copyright : Isaac Jones 2003-2004, -- Duncan Coutts 2008 ----- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Simple/Command.hs view
@@ -2,13 +2,17 @@ -- | -- Module : Distribution.Simple.Command -- Copyright : Duncan Coutts 2007--- --- Maintainer : Duncan Coutts <duncan@haskell.org>--- 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
Distribution/Simple/Compiler.hs view
@@ -2,12 +2,20 @@ -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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)
Distribution/Simple/Configure.hs view
@@ -2,13 +2,23 @@ -- | -- Module : Distribution.Simple.Configure -- Copyright : Isaac Jones 2003-2005--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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 ] -}
Distribution/Simple/GHC.hs view
@@ -2,14 +2,35 @@ -- | -- Module : Distribution.Simple.GHC -- Copyright : Isaac Jones 2003-2007--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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 <ldLibName>.tmp, and any existing file- -- named <ldLibName> is included when linking. The- -- output is renamed to <libName>.+ -- This method is called iteratively by xargs. The+ -- output goes to <ldLibName>.tmp, and any existing file+ -- named <ldLibName> is included when linking. The+ -- output is renamed to <libName>. 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))
+ Distribution/Simple/GHC/IPI641.hs view
@@ -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+ }
+ Distribution/Simple/GHC/IPI642.hs view
@@ -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+ }
Distribution/Simple/GHC/Makefile.hs view
@@ -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",""] }
Distribution/Simple/GHC/Makefile.in view
@@ -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 \
Distribution/Simple/Haddock.hs view
@@ -2,14 +2,19 @@ -- | -- Module : Distribution.Simple.Haddock -- Copyright : Isaac Jones 2003-2005--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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_
Distribution/Simple/Hugs.hs view
@@ -2,12 +2,12 @@ -- | -- Module : Distribution.Simple.Hugs -- Copyright : Isaac Jones 2003-2006--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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 }
Distribution/Simple/Install.hs view
@@ -2,14 +2,14 @@ -- | -- Module : Distribution.Simple.Install -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Simple/InstallDirs.hs view
@@ -9,15 +9,17 @@ -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 ----- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Simple/JHC.hs view
@@ -2,12 +2,12 @@ -- | -- Module : Distribution.Simple.JHC -- Copyright : Isaac Jones 2003-2006--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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))
Distribution/Simple/LocalBuildInfo.hs view
@@ -2,16 +2,17 @@ -- | -- Module : Distribution.Simple.LocalBuildInfo -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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" #-}
Distribution/Simple/NHC.hs view
@@ -2,11 +2,12 @@ -- | -- Module : Distribution.Simple.NHC -- Copyright : Isaac Jones 2003-2006--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Simple/PackageIndex.hs view
@@ -10,14 +10,12 @@ -- Copyright : (c) David Himmelstrup 2005, -- Bjorn Bringert 2007, -- Duncan Coutts 2008--- License : BSD-like ----- Maintainer : Duncan Coutts <duncan@haskell.org>--- 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
Distribution/Simple/PreProcess.hs view
@@ -1,19 +1,20 @@ ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.PreProcess--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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 =
Distribution/Simple/PreProcess/Unlit.hs view
@@ -2,9 +2,8 @@ -- | -- Module : Distribution.Simple.PreProcess.Unlit -- Copyright : ...--- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>--- Stability : Stable+--+-- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Remove the \"literal\" markups from a Haskell source file, including
Distribution/Simple/Program.hs view
@@ -2,14 +2,24 @@ -- | -- Module : Distribution.Simple.Program -- Copyright : Isaac Jones 2006--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Simple/Register.hs view
@@ -2,13 +2,25 @@ -- | -- Module : Distribution.Simple.Register -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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)
Distribution/Simple/Setup.hs view
@@ -2,13 +2,29 @@ -- | -- Module : Distribution.Simple.Setup -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>+-- 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 -> []
− Distribution/Simple/SetupWrapper.hs
@@ -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]
Distribution/Simple/SrcDist.hs view
@@ -2,14 +2,19 @@ -- | -- Module : Distribution.Simple.SrcDist -- Copyright : Simon Marlow 2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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) }
Distribution/Simple/UserHooks.hs view
@@ -2,19 +2,25 @@ -- | -- Module : Distribution.Simple.UserHooks -- Copyright : Isaac Jones 2003-2005--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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.
Distribution/Simple/Utils.hs view
@@ -9,13 +9,15 @@ -- Module : Distribution.Simple.Utils -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- portions Copyright (c) 2007, Galois Inc.--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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"
Distribution/System.hs view
@@ -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 == '-')
Distribution/Text.hs view
@@ -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
Distribution/Verbosity.hs view
@@ -3,10 +3,13 @@ -- Module : Distribution.Verbosity -- Copyright : Ian Lynagh 2007 ----- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Distribution/Version.hs view
@@ -2,12 +2,13 @@ -- | -- Module : Distribution.Version -- Copyright : Isaac Jones, Simon Marlow 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
Language/Haskell/Extension.hs view
@@ -2,9 +2,8 @@ -- | -- Module : Language.Haskell.Extension -- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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
README view
@@ -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
changelog view
@@ -1,6 +1,24 @@ -*-change-log-*- -1.5.x (current development version)+1.6.0.0 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> August 2008 * Fix executable stripping default