Cabal 1.2.4.0 → 1.4.0.0
raw patch · 53 files changed
+9352/−6648 lines, 53 filesdep +arraydep −unixdep ~basedep ~containersdep ~directory
Dependencies added: array
Dependencies removed: unix
Dependency ranges changed: base, containers, directory, filepath, old-time, pretty, process
Files
- Cabal.cabal +24/−15
- Distribution/Compat/Directory.hs +0/−198
- Distribution/Compat/Exception.hs +0/−15
- Distribution/Compat/Map.hs +0/−86
- Distribution/Compat/RawSystem.hs +0/−17
- Distribution/Compat/ReadP.hs +42/−42
- Distribution/Compat/TempFile.hs +38/−33
- Distribution/Compiler.hs +101/−16
- Distribution/Configuration.hs +0/−460
- Distribution/GetOpt.hs +2/−2
- Distribution/InstalledPackageInfo.hs +44/−38
- Distribution/License.hs +72/−8
- Distribution/Make.hs +94/−100
- Distribution/Package.hs +94/−18
- Distribution/PackageDescription.hs +1330/−1679
- Distribution/PackageDescription/Check.hs +616/−0
- Distribution/PackageDescription/Configuration.hs +503/−0
- Distribution/ParseUtils.hs +125/−227
- Distribution/ReadE.hs +83/−0
- Distribution/Simple.hs +262/−436
- Distribution/Simple/Build.hs +57/−57
- Distribution/Simple/BuildPaths.hs +145/−0
- Distribution/Simple/Command.hs +527/−0
- Distribution/Simple/Compiler.hs +39/−26
- Distribution/Simple/Configure.hs +327/−200
- Distribution/Simple/GHC.hs +243/−184
- Distribution/Simple/GHC/PackageConfig.hs +0/−169
- Distribution/Simple/GHC/mkGHCMakefile.sh +7/−0
- Distribution/Simple/Haddock.hs +231/−161
- Distribution/Simple/Hugs.hs +46/−43
- Distribution/Simple/Install.hs +44/−55
- Distribution/Simple/InstallDirs.hs +215/−181
- Distribution/Simple/JHC.hs +45/−29
- Distribution/Simple/LocalBuildInfo.hs +31/−54
- Distribution/Simple/NHC.hs +175/−28
- Distribution/Simple/PackageIndex.hs +464/−0
- Distribution/Simple/PreProcess.hs +30/−52
- Distribution/Simple/PreProcess/Unlit.hs +132/−56
- Distribution/Simple/Program.hs +38/−21
- Distribution/Simple/Register.hs +102/−168
- Distribution/Simple/Setup.hs +1434/−1031
- Distribution/Simple/SetupWrapper.hs +24/−28
- Distribution/Simple/SrcDist.hs +199/−124
- Distribution/Simple/UserHooks.hs +213/−0
- Distribution/Simple/Utils.hs +437/−294
- Distribution/System.hs +129/−11
- Distribution/Text.hs +50/−0
- Distribution/Verbosity.hs +10/−11
- Distribution/Version.hs +57/−265
- Language/Haskell/Extension.hs +110/−3
- README +105/−0
- changelog +256/−0
- mkGHCMakefile.sh +0/−7
Cabal.cabal view
@@ -1,9 +1,11 @@ Name: Cabal-Version: 1.2.4.0+Version: 1.4.0.0 Copyright: 2003-2006, Isaac Jones+ 2005-2008, Duncan Coutts License: BSD3 License-File: LICENSE Author: Isaac Jones <ijones@syntaxpolice.org>+ Duncan Coutts <duncan@haskell.org> Maintainer: cabal-devel@haskell.org Homepage: http://www.haskell.org/cabal/ Synopsis: A framework for packaging Haskell software@@ -21,23 +23,28 @@ -- that we build Setup.lhs using our own local Cabal source code. Extra-Source-Files:- mkGHCMakefile.sh Distribution/Simple/GHC/Makefile.in+ README changelog+ Distribution/Simple/GHC/mkGHCMakefile.sh+ Distribution/Simple/GHC/Makefile.in Flag small_base Description: Choose the new smaller, split-up base package. Library if flag(small_base)- Build-Depends: base >= 3, pretty, directory, old-time, process, containers+ Build-Depends: base >= 3 && < 4,+ directory >= 1 && < 1.1,+ process >= 1 && < 1.1,+ old-time >= 1 && < 1.1,+ containers >= 0.1 && < 0.2,+ array >= 0.1 && < 0.2,+ pretty >= 1 && < 1.1 else Build-Depends: base < 3- Build-Depends: filepath-- if impl(ghc < 6.3)- Build-Depends: unix+ Build-Depends: filepath >= 1 && < 1.2 GHC-Options: -Wall- CPP-Options: "-DCABAL_VERSION=1,2,4,0"+ CPP-Options: "-DCABAL_VERSION=1,4,0,0" nhc98-Options: -K4M Exposed-Modules:@@ -49,15 +56,17 @@ Distribution.Make, Distribution.Package, Distribution.PackageDescription,- Distribution.Configuration,+ Distribution.PackageDescription.Configuration,+ Distribution.PackageDescription.Check, Distribution.ParseUtils,+ Distribution.ReadE, Distribution.Simple, Distribution.Simple.Build,+ Distribution.Simple.BuildPaths,+ Distribution.Simple.Command, Distribution.Simple.Compiler, Distribution.Simple.Configure, Distribution.Simple.GHC,- Distribution.Simple.GHC.Makefile,- Distribution.Simple.GHC.PackageConfig, Distribution.Simple.Haddock, Distribution.Simple.Hugs, Distribution.Simple.Install,@@ -65,6 +74,7 @@ Distribution.Simple.JHC, Distribution.Simple.LocalBuildInfo, Distribution.Simple.NHC,+ Distribution.Simple.PackageIndex, Distribution.Simple.PreProcess, Distribution.Simple.PreProcess.Unlit, Distribution.Simple.Program,@@ -72,8 +82,10 @@ Distribution.Simple.Setup, Distribution.Simple.SetupWrapper, Distribution.Simple.SrcDist,+ Distribution.Simple.UserHooks, Distribution.Simple.Utils, Distribution.System,+ Distribution.Text, Distribution.Verbosity, Distribution.Version, Distribution.Compat.ReadP,@@ -81,10 +93,7 @@ Other-Modules: Distribution.GetOpt,- Distribution.Compat.Map,- Distribution.Compat.Directory,- Distribution.Compat.Exception,- Distribution.Compat.RawSystem, Distribution.Compat.TempFile+ Distribution.Simple.GHC.Makefile Extensions: CPP
− Distribution/Compat/Directory.hs
@@ -1,198 +0,0 @@-{-# OPTIONS -cpp #-}--- #hide-module Distribution.Compat.Directory (- module System.Directory,-#if (__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ <= 602)- findExecutable, copyFile, getHomeDirectory, createDirectoryIfMissing,- removeDirectoryRecursive, getTemporaryDirectory,-#endif- getDirectoryContentsWithoutSpecial- ) where--#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604-#if __GLASGOW_HASKELL__ < 603-#include "config.h"-#else-#include "ghcconfig.h"-#endif-#endif--#if !(__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ <= 602)--import System.Directory--#else /* to end of file... */--import System.Environment ( getEnv )-import System.FilePath-import System.IO-import Foreign-import System.Directory-import Distribution.Compat.Exception (bracket)-import Control.Monad (when, unless)-#if !(mingw32_HOST_OS || mingw32_TARGET_OS)-import System.Posix (getFileStatus,setFileMode,fileMode,accessTime,- modificationTime,setFileTimes)-#endif-import Data.List ( scanl1 )--findExecutable :: String -> IO (Maybe FilePath)-findExecutable binary = do- path <- getEnv "PATH"- search (splitSearchPath path)- where- search :: [FilePath] -> IO (Maybe FilePath)- search [] = return Nothing- search (d:ds) = do- let path = d </> binary <.> exeSuffix- b <- doesFileExist path- if b then return (Just path)- else search ds--exeSuffix :: String-#if mingw32_HOST_OS || mingw32_TARGET_OS-exeSuffix = "exe"-#else-exeSuffix = ""-#endif--copyPermissions :: FilePath -> FilePath -> IO ()-#if !(mingw32_HOST_OS || mingw32_TARGET_OS)-copyPermissions src dest- = do srcStatus <- getFileStatus src- setFileMode dest (fileMode srcStatus)-#else-copyPermissions src dest- = getPermissions src >>= setPermissions dest-#endif---copyFileTimes :: FilePath -> FilePath -> IO ()-#if !(mingw32_HOST_OS || mingw32_TARGET_OS)-copyFileTimes src dest- = do st <- getFileStatus src- let atime = accessTime st- mtime = modificationTime st- setFileTimes dest atime mtime-#else-copyFileTimes src dest- = return ()-#endif---- |Preserves permissions and, if possible, atime+mtime-copyFile :: FilePath -> FilePath -> IO ()-copyFile src dest - | dest == src = fail "copyFile: source and destination are the same file"-#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))- | otherwise = do readFile src >>= writeFile dest- try (copyPermissions src dest)- return ()-#else- | otherwise = bracket (openBinaryFile src ReadMode) hClose $ \hSrc ->- bracket (openBinaryFile dest WriteMode) hClose $ \hDest ->- do allocaBytes bufSize $ \buffer -> copyContents hSrc hDest buffer- try (copyPermissions src dest)- try (copyFileTimes src dest)- return ()- where bufSize = 1024- copyContents hSrc hDest buffer- = do count <- hGetBuf hSrc buffer bufSize- when (count > 0) $ do hPutBuf hDest buffer count- copyContents hSrc hDest buffer-#endif--getHomeDirectory :: IO FilePath-getHomeDirectory = getEnv "HOME"--createDirectoryIfMissing :: Bool -- ^ Create its parents too?- -> FilePath -- ^ The path to the directory you want to make- -> IO ()-createDirectoryIfMissing parents file = do- b <- doesDirectoryExist file- case (b,parents, file) of - (_, _, "") -> return ()- (True, _, _) -> return ()- (_, True, _) -> mapM_ (createDirectoryIfMissing False) (pathParents file)- (_, False, _) -> createDirectory file--pathParents = scanl1 (</>) . splitDirectories- -- > scanl1 (</>) (splitDirectories "/a/b/c")- -- ["/","/a","/a/b","/a/b/c"]--removeDirectoryRecursive :: FilePath -> IO ()-removeDirectoryRecursive startLoc = do- cont <- getDirectoryContentsWithoutSpecial startLoc- mapM_ (rm . (startLoc </>)) cont- removeDirectory startLoc- where- rm :: FilePath -> IO ()- rm f = do temp <- try (removeFile f)- case temp of- Left e -> do isDir <- doesDirectoryExist f- -- If f is not a directory, re-throw the error- unless isDir $ ioError e- removeDirectoryRecursive f- Right _ -> return ()--{- | Returns the current directory for temporary files.--On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@-environment variable or \"\/tmp\" if the variable isn\'t defined.-On Windows, the function checks for the existence of environment variables in -the following order and uses the first path found:--* -TMP environment variable. --*-TEMP environment variable. --*-USERPROFILE environment variable. --*-The Windows directory--The operation may fail with:--* 'UnsupportedOperation'-The operating system has no notion of temporary directory.--The function doesn\'t verify whether the path exists.--}-getTemporaryDirectory :: IO FilePath-getTemporaryDirectory = do-#if defined(mingw32_HOST_OS)- allocaBytes long_path_size $ \pPath -> do- r <- c_GetTempPath (fromIntegral long_path_size) pPath- peekCString pPath-#else- catch (getEnv "TMPDIR") (\ex -> return "/tmp")-#endif--#if defined(mingw32_HOST_OS)-foreign import ccall unsafe "__hscore_getFolderPath"- c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CString - -> IO CInt-foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt-foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt-foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt-foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt--foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt--raiseUnsupported loc = - ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)--#endif--#endif--getDirectoryContentsWithoutSpecial :: FilePath -> IO [FilePath]-getDirectoryContentsWithoutSpecial =- fmap (filter (not . flip elem [".", ".."])) . getDirectoryContents-
− Distribution/Compat/Exception.hs
@@ -1,15 +0,0 @@-{-# OPTIONS -cpp #-}--- #hide-module Distribution.Compat.Exception (bracket,finally) where--#ifdef __NHC__-import System.IO.Error (catch, ioError)-import IO (bracket)-#else-import Control.Exception (bracket,finally)-#endif--#ifdef __NHC__-finally :: IO a -> IO b -> IO a-finally thing after = bracket (return ()) (const after) (const thing)-#endif
− Distribution/Compat/Map.hs
@@ -1,86 +0,0 @@-{-# OPTIONS -cpp #-}--- #hide-module Distribution.Compat.Map (- Map,- member, lookup, findWithDefault,- empty,- insert, insertWith,- update,- union, unionWith, unions,- difference,- elems, keys,- fromList, fromListWith,- toAscList-) where--import Prelude hiding ( lookup )--#if __GLASGOW_HASKELL__ >= 603 || !__GLASGOW_HASKELL__-import Data.Map-#else-import Data.FiniteMap--type Map k a = FiniteMap k a--instance Functor (FiniteMap k) where- fmap f = mapFM (const f)--member :: Ord k => k -> Map k a -> Bool-member = elemFM--lookup :: Ord k => k -> Map k a -> Maybe a-lookup = flip lookupFM--findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault a k m = lookupWithDefaultFM m a k--empty :: Map k a-empty = emptyFM--insert :: Ord k => k -> a -> Map k a -> Map k a-insert k a m = addToFM m k a---- This might be able to use delFromFM, but I'm confused by the--- IF_NOT_GHC(delFromFM COMMA)--- in the Data.FiniteMap export list in ghc 6.2.-delete :: Ord k => k -> Map k a -> Map k a-delete k m = delListFromFM m [k]--insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith c k a m = addToFM_C (flip c) m k a--update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a-update f k m = case lookup k m of- Nothing -> m- Just a -> case f a of- Nothing -> delete k m- Just a' -> insert k a' m--union :: Ord k => Map k a -> Map k a -> Map k a-union = flip plusFM--unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWith c l r = plusFM_C (flip c) r l--unions :: Ord k => [Map k a] -> Map k a-unions = foldl (flip plusFM) emptyFM--difference :: Ord k => Map k a -> Map k b -> Map k a-difference m1 m2 = delListFromFM m1 (keys m2)- -- minusFM wasn't polymorphic enough in GHC 6.2.x--elems :: Map k a -> [a]-elems = eltsFM--keys :: Map k a -> [k]-keys = keysFM--fromList :: Ord k => [(k,a)] -> Map k a-fromList = listToFM--fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a -fromListWith c = addListToFM_C (flip c) emptyFM--toAscList :: Map k a -> [(k,a)]-toAscList = fmToList-#endif
− Distribution/Compat/RawSystem.hs
@@ -1,17 +0,0 @@-{-# OPTIONS -cpp #-}--- #hide-module Distribution.Compat.RawSystem (rawSystem) where--#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 602-import Data.List (intersperse)-import System.Cmd (system)-import System.Exit (ExitCode)-#else-import System.Cmd (rawSystem)-#endif--#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 602-rawSystem :: String -> [String] -> IO ExitCode-rawSystem p args = system $ concat $ intersperse " " (p : map esc args)- where esc arg = "'" ++ arg ++ "'" -- this is hideously broken, actually-#endif
Distribution/Compat/ReadP.hs view
@@ -106,7 +106,7 @@ (Get f) >>= k = Get (\c -> f c >>= k) (Look f) >>= k = Look (\s -> f s >>= k)- Fail >>= k = Fail+ Fail >>= _ = Fail (Result x p) >>= k = k x `mplus` (p >>= k) (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] @@ -157,9 +157,9 @@ fail _ = R (\_ -> Fail) R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) -instance MonadPlus (Parser r s) where- mzero = pfail- mplus = (+++)+--instance MonadPlus (Parser r s) where+-- mzero = pfail+-- mplus = (+++) -- --------------------------------------------------------------------------- -- Operations over P@@ -169,7 +169,7 @@ final [] = Fail final r = Final r ---run :: P s a -> ReadS a+run :: P c a -> ([c] -> [(a, [c])]) run (Get f) (c:s) = run (f c) s run (Look f) s = run (f s) s run (Result x p) s = (x,s) : run p s@@ -179,25 +179,25 @@ -- --------------------------------------------------------------------------- -- Operations over ReadP ---get :: ReadP Char+get :: ReadP r Char -- ^ Consumes and returns the next character. -- Fails if there is no input left. get = R Get ---look :: ReadP String+look :: ReadP r String -- ^ Look-ahead: returns the part of the input that is left, without -- consuming it. look = R Look ---pfail :: ReadP a+pfail :: ReadP r a -- ^ Always fails. pfail = R (\_ -> Fail) ---(+++) :: ReadP r a -> ReadP r a -> ReadP r a+(+++) :: ReadP r a -> ReadP r a -> ReadP r a -- ^ Symmetric choice. R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) ---(<++) :: ReadP a -> ReadP a -> ReadP a+(<++) :: ReadP a a -> ReadP r a -> ReadP r a -- ^ Local, exclusive, left-biased choice: If left parser -- locally produces any result at all, then right parser is -- not used.@@ -205,16 +205,16 @@ do s <- look probe (f return) s 0 where- probe (Get f) (c:s) n = probe (f c) s (n+1)- probe (Look f) s n = probe (f s) s n+ probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int)+ probe (Look f') s n = probe (f' s) s n probe p@(Result _ _) _ n = discard n >> R (p >>=) probe (Final r) _ _ = R (Final r >>=) probe _ _ _ = q discard 0 = return ()- discard n = get >> discard (n-1)+ discard n = get >> discard (n-1 :: Int) ---gather :: ReadP a -> ReadP (String, a)+gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) -- ^ 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@@ -223,24 +223,24 @@ R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) where gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))- gath l Fail = Fail+ gath _ Fail = Fail gath l (Look f) = Look (\s -> gath l (f s)) gath l (Result k p) = k (l []) `mplus` gath l p- gath l (Final r) = error "do not use readS_to_P in gather!"+ gath _ (Final _) = error "do not use readS_to_P in gather!" -- --------------------------------------------------------------------------- -- Derived operations ---satisfy :: (Char -> Bool) -> ReadP Char+satisfy :: (Char -> Bool) -> ReadP r Char -- ^ Consumes and returns the next character, if it satisfies the -- specified predicate. satisfy p = do c <- get; if p c then return c else pfail ---char :: Char -> ReadP Char+char :: Char -> ReadP r Char -- ^ Parses and returns the specified character. char c = satisfy (c ==) ---string :: String -> ReadP String+string :: String -> ReadP r String -- ^ Parses and returns the specified string. string this = do s <- look; scan this s where@@ -248,7 +248,7 @@ scan (x:xs) (y:ys) | x == y = do get; scan xs ys scan _ _ = do pfail ---munch :: (Char -> Bool) -> ReadP String+munch :: (Char -> Bool) -> ReadP r String -- ^ Parses the first zero or more characters satisfying the predicate. munch p = do s <- look@@ -257,19 +257,19 @@ scan (c:cs) | p c = do get; s <- scan cs; return (c:s) scan _ = do return "" ---munch1 :: (Char -> Bool) -> ReadP String+munch1 :: (Char -> Bool) -> ReadP r String -- ^ Parses the first one or more characters satisfying the predicate. munch1 p = do c <- get if p c then do s <- munch p; return (c:s) else pfail ---choice :: [ReadP a] -> ReadP a+choice :: [ReadP r a] -> ReadP r a -- ^ Combines all parsers in the specified list. choice [] = pfail choice [p] = p choice (p:ps) = p +++ choice ps ---skipSpaces :: ReadP ()+skipSpaces :: ReadP r () -- ^ Skips all whitespace. skipSpaces = do s <- look@@ -278,12 +278,12 @@ skip (c:s) | isSpace c = do get; skip s skip _ = do return () ---count :: Int -> ReadP a -> ReadP [a]+count :: Int -> ReadP r a -> ReadP r [a] -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of -- results is returned. count n p = sequence (replicate n p) ---between :: ReadP open -> ReadP close -> ReadP a -> ReadP a+between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a -- ^ @ between open close p @ parses @open@, followed by @p@ and finally -- @close@. Only the value of @p@ is returned. between open close p = do open@@ -291,66 +291,66 @@ close return x ---option :: a -> ReadP a -> ReadP a+option :: a -> ReadP r a -> ReadP r a -- ^ @option x p@ will either parse @p@ or return @x@ without consuming -- any input. option x p = p +++ return x ---optional :: ReadP a -> ReadP ()+optional :: ReadP r a -> ReadP r () -- ^ @optional p@ optionally parses @p@ and always returns @()@. optional p = (p >> return ()) +++ return () ---many :: ReadP a -> ReadP [a]+many :: ReadP r a -> ReadP r [a] -- ^ Parses zero or more occurrences of the given parser. many p = return [] +++ many1 p ---many1 :: ReadP a -> ReadP [a]+many1 :: ReadP r a -> ReadP r [a] -- ^ Parses one or more occurrences of the given parser. many1 p = liftM2 (:) p (many p) ---skipMany :: ReadP a -> ReadP ()+skipMany :: ReadP r a -> ReadP r () -- ^ Like 'many', but discards the result. skipMany p = many p >> return () ---skipMany1 :: ReadP a -> ReadP ()+skipMany1 :: ReadP r a -> ReadP r () -- ^ Like 'many1', but discards the result. skipMany1 p = p >> skipMany p ---sepBy :: ReadP a -> ReadP sep -> ReadP [a]+sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. -- Returns a list of values returned by @p@. sepBy p sep = sepBy1 p sep +++ return [] ---sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]+sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. -- Returns a list of values returned by @p@. sepBy1 p sep = liftM2 (:) p (many (sep >> p)) ---endBy :: ReadP a -> ReadP sep -> ReadP [a]+endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended -- by @sep@. endBy p sep = many (do x <- p ; sep ; return x) ---endBy1 :: ReadP a -> ReadP sep -> ReadP [a]+endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended -- by @sep@. endBy1 p sep = many1 (do x <- p ; sep ; return x) ---chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. -- Returns a value produced by a /right/ associative application of all -- functions returned by @op@. If there are no occurrences of @p@, @x@ is -- returned. chainr p op x = chainr1 p op +++ return x ---chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. -- Returns a value produced by a /left/ associative application of all -- functions returned by @op@. If there are no occurrences of @p@, @x@ is -- returned. chainl p op x = chainl1 p op +++ return x ---chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a -- ^ Like 'chainr', but parses one or more occurrences of @p@. chainr1 p op = scan where scan = p >>= rest@@ -359,7 +359,7 @@ return (f x y) +++ return x ---chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a -- ^ Like 'chainl', but parses one or more occurrences of @p@. chainl1 p op = p >>= rest where rest x = do f <- op@@ -367,7 +367,7 @@ rest (f x y) +++ return x ---manyTill :: ReadP a -> ReadP end -> ReadP [a]+manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ -- succeeds. Returns a list of values returned by @p@. manyTill p end = scan@@ -376,14 +376,14 @@ -- --------------------------------------------------------------------------- -- Converting between ReadP and Read ---readP_to_S :: ReadP a -> ReadS a+readP_to_S :: ReadP a a -> ReadS a -- ^ Converts a parser into a Haskell ReadS-style function. -- This is the main way in which you can \"run\" a 'ReadP' parser: -- the expanded type is -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ readP_to_S (R f) = run (f return) ---readS_to_P :: ReadS a -> ReadP a+readS_to_P :: ReadS a -> ReadP r a -- ^ Converts a Haskell ReadS-style function into a parser. -- Warning: This introduces local backtracking in the resulting -- parser, and therefore a possible inefficiency.
Distribution/Compat/TempFile.hs view
@@ -1,61 +1,66 @@ {-# 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 #-} -- #hide-module Distribution.Compat.TempFile (openTempFile, withTempFile) where--import System.IO (openFile, Handle, IOMode(ReadWriteMode))-import System.Directory (doesFileExist, removeFile)-import Control.Exception (finally,try)--import System.FilePath ( (</>), (<.>) )+module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) where -#if (__GLASGOW_HASKELL__ || __HUGS__)+#if __NHC__ || __HUGS__+import System.IO (openFile, openBinaryFile,+ Handle, IOMode(ReadWriteMode))+import System.Directory (doesFileExist)+import System.FilePath ((</>), (<.>), splitExtension)+#if __NHC__+import System.Posix.Types (CPid(..))+foreign import ccall unsafe "getpid" c_getpid :: IO CPid+#else import System.Posix.Internals (c_getpid)+#endif #else-import System.Posix.Types (CPid(..))+import System.IO (openTempFile, openBinaryTempFile) #endif - -- ------------------------------------------------------------ -- * temporary files -- ------------------------------------------------------------ --- TODO: this function *really really really* should be--- eliminated and replaced with System.IO.openTempFile,--- except that is currently GHC-only for no valid reason.+-- This is here for Haskell implementations that do not come with+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.+-- TODO: Not sure about jhc +#if __NHC__ || __HUGS__ -- use a temporary filename that doesn't already exist. -- NB. *not* secure (we don't atomically lock the tmp file we get) openTempFile :: FilePath -> String -> IO (FilePath, Handle) openTempFile tmp_dir template = do x <- getProcessID findTempName x- where + where+ (templateBase, templateExt) = splitExtension template+ findTempName :: Int -> IO (FilePath, Handle) findTempName x- = do let filename = template ++ show x- path = tmp_dir </> filename- b <- doesFileExist path- if b then findTempName (x+1)- else do hnd <- openFile path ReadWriteMode+ = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt+ b <- doesFileExist path+ if b then findTempName (x+1)+ else do hnd <- openFile path ReadWriteMode return (path, hnd) -#if !(__GLASGOW_HASKELL__ || __HUGS__)-foreign import ccall unsafe "getpid" c_getpid :: IO CPid-#endif--getProcessID :: IO Int-getProcessID = c_getpid >>= return . fromIntegral---- use a temporary filename that doesn't already exist.--- NB. *not* secure (we don't atomically lock the tmp file we get)-withTempFile :: FilePath -> String -> (FilePath -> IO a) -> IO a-withTempFile tmp_dir extn action+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)+openBinaryTempFile tmp_dir template = do x <- getProcessID findTempName x where+ (templateBase, templateExt) = splitExtension template+ findTempName :: Int -> IO (FilePath, Handle) findTempName x- = do let filename = ("tmp" ++ show x) <.> extn- path = tmp_dir </> filename+ = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt b <- doesFileExist path if b then findTempName (x+1)- else action path `finally` try (removeFile path)+ else do hnd <- openBinaryFile path ReadWriteMode+ return (path, hnd) +getProcessID :: IO Int+getProcessID = fmap fromIntegral c_getpid+#endif
Distribution/Compiler.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compiler@@ -40,22 +39,108 @@ (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.Compiler (CompilerFlavor(..), defaultCompilerFlavor) where+module Distribution.Compiler (+ -- * Compiler flavor+ CompilerFlavor(..),+ buildCompilerFlavor,+ defaultCompilerFlavor,+ parseCompilerFlavorCompat, -data CompilerFlavor- = GHC | NHC | Hugs | HBC | Helium | JHC | OtherCompiler String+ -- * Compiler id+ CompilerId(..),+ ) where++import Distribution.Version (Version(..))++import qualified System.Info (compilerName)+import Distribution.Text (Text(..), display)+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>))++import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)+import Control.Monad (when)++data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC+ | OtherCompiler String deriving (Show, Read, Eq, Ord) +knownCompilerFlavors :: [CompilerFlavor]+knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC]++instance Text CompilerFlavor where+ disp (OtherCompiler name) = Disp.text name+ disp NHC = Disp.text "nhc98"+ disp other = Disp.text (lowercase (show other))++ parse = do+ comp <- Parse.munch1 Char.isAlphaNum+ when (all Char.isDigit comp) Parse.pfail+ return (classifyCompilerFlavor comp)++classifyCompilerFlavor :: String -> CompilerFlavor+classifyCompilerFlavor s =+ case lookup (lowercase s) compilerMap of+ Just compiler -> compiler+ Nothing -> OtherCompiler s+ where+ compilerMap = [ (display compiler, compiler)+ | compiler <- knownCompilerFlavors ]+++--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use+-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.++-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.+--+-- It is compatible in the sense that it accepts only the same strings,+-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.+-- The point of this is that we do not allow extra valid values that would+-- upset older Cabal versions that had a stricter parser however we cope with+-- new values more gracefully so that we'll be able to introduce new value in+-- future without breaking things so much.+--+parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor+parseCompilerFlavorCompat = do+ comp <- Parse.munch1 Char.isAlphaNum+ when (all Char.isDigit comp) Parse.pfail+ case lookup comp compilerMap of+ Just compiler -> return compiler+ Nothing -> return (OtherCompiler comp)+ where+ compilerMap = [ (show compiler, compiler)+ | compiler <- knownCompilerFlavors+ , compiler /= YHC ]++buildCompilerFlavor :: CompilerFlavor+buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName++-- | The default compiler flavour to pick when compiling stuff. This defaults+-- to the compiler used to build the Cabal lib.+--+-- However if it's not a recognised compiler then it's 'Nothing' and the user+-- will have to specify which compiler they want.+-- defaultCompilerFlavor :: Maybe CompilerFlavor-defaultCompilerFlavor =-#if defined(__GLASGOW_HASKELL__)- Just GHC-#elif defined(__NHC__)- Just NHC-#elif defined(__JHC__)- Just JHC-#elif defined(__HUGS__)- Just Hugs-#else- Nothing-#endif+defaultCompilerFlavor = case buildCompilerFlavor of+ OtherCompiler _ -> Nothing+ _ -> Just buildCompilerFlavor++-- ------------------------------------------------------------+-- * Compiler Id+-- ------------------------------------------------------------++data CompilerId = CompilerId CompilerFlavor Version+ deriving (Eq, Ord, Read, Show)++instance Text CompilerId where+ disp (CompilerId f (Version [] _)) = disp f+ disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v++ parse = do+ flavour <- parse+ version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] [])+ return (CompilerId flavour version)++lowercase :: String -> String+lowercase = map Char.toLower
− Distribution/Configuration.hs
@@ -1,460 +0,0 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- Module : Distribution.Configuration--- Copyright : Thomas Schilling, 2007--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- Stability : alpha--- Portability : portable------ Configurations--{- 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.Configuration (- Flag(..),- ConfVar(..),- Condition(..), parseCondition, simplifyCondition,- CondTree(..), ppCondTree, mapTreeData,- --satisfyFlags, - resolveWithFlags, ignoreConditions,- DepTestRslt(..)- ) where--import Distribution.Compat.ReadP as ReadP hiding ( char )-import qualified Distribution.Compat.ReadP as ReadP ( char )-import Distribution.Version - ( Version(..), VersionRange(..), withinRange- , showVersionRange, parseVersionRange )--import Text.PrettyPrint.HughesPJ--import Data.Char ( isAlphaNum, toLower )-import Data.Maybe ( catMaybes, maybeToList )-import Data.Monoid--#ifdef DEBUG-import Data.List ( (\\) )-import Distribution.ParseUtils-#endif------------------------------------------------------------------------------------ | 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 :: String- , flagDescription :: String- , flagDefault :: Bool- }--instance Show Flag where show (MkFlag n _ _) = n---- | A @ConfFlag@ represents an user-defined flag-data ConfFlag = ConfFlag String- deriving Eq---- | A @ConfVar@ represents the variable type used. -data ConfVar = OS String - | Arch String - | Flag ConfFlag- | Impl String VersionRange- deriving Eq--instance Show ConfVar where- show (OS n) = "os(" ++ n ++ ")"- show (Arch n) = "arch(" ++ n ++ ")"- show (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"- show (Impl c v) = "impl(" ++ c ++ " " ++ showVersionRange 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)- -instance Show c => Show (Condition c) where- show c = render $ ppCond c---- | Pretty print a @Condition@.-ppCond :: Show c => Condition c -> Doc-ppCond (Var x) = text (show x)-ppCond (Lit b) = text (show b)-ppCond (CNot c) = char '!' <> parens (ppCond c)-ppCond (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]-ppCond (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]----- | Simplify the condition and return its free variables.-simplifyCondition :: Condition c- -> (c -> Either d Bool) -- ^ (partial) variable assignment- -> (Condition d, [d])-simplifyCondition cond i = fv . walk $ cond- where- walk cnd = case cnd of- Var v -> either Var Lit (i v)- Lit b -> Lit b- CNot c -> case walk c of- Lit True -> Lit False- Lit False -> Lit True- c' -> CNot c'- COr c d -> case (walk c, walk d) of- (Lit False, d') -> d'- (Lit True, _) -> Lit True- (c', Lit False) -> c'- (_, Lit True) -> Lit True- (c',d') -> COr c' d'- CAnd c d -> case (walk c, walk d) of- (Lit False, _) -> Lit False- (Lit True, d') -> d'- (_, Lit False) -> Lit False- (c', Lit True) -> c'- (c',d') -> CAnd c' d'- -- gather free vars- fv c = (c, fv' c)- fv' c = case c of- Var v -> [v]- Lit _ -> []- CNot c' -> fv' c'- COr c1 c2 -> fv' c1 ++ fv' c2- CAnd c1 c2 -> fv' c1 ++ fv' c2---- | Simplify a configuration condition using the os and arch names. Returns--- the names of all the flags occurring in the condition.-simplifyWithSysParams :: String -> String -> (String, Version) -> Condition ConfVar -> - (Condition ConfFlag, [String])-simplifyWithSysParams os arch (impl, implVer) cond = (cond', flags)- where- (cond', fvs) = simplifyCondition cond interp - interp (OS name) = Right $ lcase name == lcase os- || lcase name `elem` osAliases (lcase os)- interp (Arch name) = Right $ lcase name == lcase arch- interp (Impl i vr) = Right $ lcase impl == lcase i- && implVer `withinRange` vr- interp (Flag f) = Left f- flags = [ fname | ConfFlag fname <- fvs ]-- --FIXME: use Distribution.System.OS type and alias list:- osAliases "mingw32" = ["windows"]- osAliases "solaris2" = ["solaris"]- osAliases _ = []- lcase = map toLower---- XXX: Add instances and check------ prop_sC_idempotent cond a o = cond' == cond''--- where--- cond' = simplifyCondition cond a o--- cond'' = simplifyCondition cond' a o------ prop_sC_noLits cond a o = isLit res || not (hasLits res)--- where--- res = simplifyCondition cond a o--- hasLits (Lit _) = True--- hasLits (CNot c) = hasLits c--- hasLits (COr l r) = hasLits l || hasLits r--- hasLits (CAnd l r) = hasLits l || hasLits r--- 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 >> (lit +++ 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. OS - archCond = string "arch" >> sp >> inparens archIdent >>= return . Var . Arch - flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var . Flag . ConfFlag- implCond = string "impl" >> sp >> inparens implIdent >>= return . Var- ident = munch1 isIdentChar >>= return . map toLower- lit = ((string "true" <++ string "True") >> return (Lit True)) <++ - ((string "false" <++ string "False") >> return (Lit False))- archIdent = ident >>= return - osIdent = ident >>= return - flagIdent = ident- isIdentChar c = isAlphaNum c || (c `elem` "_-")- oper s = sp >> string s >> sp- sp = skipSpaces- implIdent = do i <- ident- vr <- sp >> option AnyVersion parseVersionRange- return $ Impl i vr----------------------------------------------------------------------------------data CondTree v c a = CondNode - { condTreeData :: a- , condTreeConstraints :: c- , condTreeComponents :: [( Condition v- , CondTree v c a- , Maybe (CondTree v c a))]- }--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)- where- g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,- fmap (mapCondTree fa fc fcnd) me)--mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a-mapTreeConstrs f = mapCondTree id f id--mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a-mapTreeConds f = mapCondTree id id f--mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b-mapTreeData f = mapCondTree f id id--instance (Show v, Show c) => Show (CondTree v c a) where- show t = render $ ppCondTree t (text . show)--ppCondTree :: Show v => CondTree v c a -> (c -> Doc) -> Doc-ppCondTree (CondNode _dat cs ifs) ppD =- (text "build-depends: " <+>- ppD cs)- $+$- (vcat $ map ppIf ifs)- where - ppIf (c,thenTree,mElseTree) = - ((text "if" <+> ppCond c <> colon) $$- nest 2 (ppCondTree thenTree ppD))- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t ppD))- mElseTree)-- --- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for--- clarity.-data DepTestRslt d = DepOk | MissingDeps d --instance Monoid d => Monoid (DepTestRslt d) where- mempty = DepOk- mappend DepOk x = x- mappend x DepOk = x- mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')---data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree----- | Try to find a flag assignment that satisfies the constaints of all trees.------ Returns either the missing dependencies, or a tuple containing the--- resulting data, the associated dependencies, and the chosen flag--- assignments.------ In case of failure, the _smallest_ number of of missing dependencies is--- returned. [XXX: Could also be specified with a function argument.]------ XXX: The current algorithm is rather naive. A better approach would be to:------ * Rule out possible paths, by taking a look at the associated dependencies.------ * Infer the required values for the conditions of these paths, and--- calculate the required domains for the variables used in these--- conditions. Then picking a flag assignment would be linear (I guess).------ This would require some sort of SAT solving, though, thus it's not--- implemented unless we really need it.--- -resolveWithFlags :: Monoid a =>- [(String,[Bool])] - -- ^ Domain for each flag name, will be tested in order.- -> String -- ^ OS name, as returned by System.Info.os- -> String -- ^ arch name, as returned by System.Info.arch- -> (String, Version) -- ^ Compiler name + version- -> [CondTree ConfVar [d] a] - -> ([d] -> DepTestRslt [d]) -- ^ Dependency test function.- -> (Either [d] -- missing dependencies- ([a], [d], [(String, Bool)]))-resolveWithFlags dom os arch impl trees checkDeps =- case try dom [] of- Right r -> Right r- Left dbt -> Left $ findShortest dbt- where - -- Check dependencies only once; might avoid some duplicate efforts.- preCheckedTrees = map ( mapTreeConstrs (\d -> (checkDeps d,d))- . mapTreeConds (fst . simplifyWithSysParams os arch impl) )- trees-- -- @try@ recursively tries all possible flag assignments in the domain and- -- 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)) - $ preCheckedTrees- in case mconcat depss of- (DepOk, ds) -> Right (as, ds, flags)- (MissingDeps mds, _) -> Left (BTN mds)- try ((n, vals):rest) flags = - tryAll $ map (\v -> try rest ((n, v):flags)) vals-- tryAll = foldr mp mz-- -- special version of `mplus' for our local purposes- mp (Left xs) (Left ys) = (Left (BTB xs ys))- mp (Left _) m@(Right _) = m- mp m@(Right _) _ = m-- -- `mzero'- mz = Left (BTN [])-- env flags flag@(ConfFlag n) = maybe (Left flag) Right . lookup n $ flags -- -- 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) = - let l = findShortest lt- r = findShortest rt- in case (l,r) of- ([], xs) -> xs -- [] is too short- (xs, []) -> xs- ([x], _) -> [x] -- single elem is optimum- (_, [x]) -> [x]- (xs, ys) -> if lazyLengthCmp xs ys- then xs else ys - -- lazy variant of @\xs ys -> length xs <= length ys@- lazyLengthCmp [] _ = True- lazyLengthCmp _ [] = False- lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys----simplifyCondTree :: (Monoid a, Monoid d) =>- (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) = - 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" ---- | 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 - : maybeToList (fmap ignoreConditions me)----------------------------------------------------------------------------------- compatibility--#if (__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ <= 602)--- This instance wasn't present in Data.Monoid in GHC 6.2-instance (Monoid a, Monoid b) => Monoid (a,b) where- mempty = (mempty, mempty)- (a1,b1) `mappend` (a2,b2) =- (a1 `mappend` a2, b1 `mappend` b2)-#endif----------------------------------------------------------------------------------- Testing--#ifdef DEBUG--tstTree :: CondTree ConfVar [Int] String-tstTree = CondNode "A" [0] - [ (CNot (Var (Flag (ConfFlag "a"))), - CondNode "B" [1] [],- Nothing)- , (CAnd (Var (Flag (ConfFlag "b"))) (Var (Flag (ConfFlag "c"))),- CondNode "C" [2] [],- Just $ CondNode "D" [3] - [ (Lit True,- CondNode "E" [4] [],- Just $ CondNode "F" [5] []) ])- ]---test_simplify = simplifyWithSysParams i386 darwin ("ghc",Version [6,6] []) tstCond - where - tstCond = COr (CAnd (Var (Arch ppc)) (Var (OS darwin)))- (CAnd (Var (Flag (ConfFlag "debug"))) (Var (OS darwin)))- [ppc,i386] = ["ppc","i386"]- [darwin,windows] = ["darwin","windows"]----test_parseCondition = map (runP 1 "test" parseCondition) testConditions- where- testConditions = [ "os(darwin)"- , "arch(i386)"- , "!os(linux)"- , "! arch(ppc)"- , "os(windows) && arch(i386)"- , "os(windows) && arch(i386) && flag(debug)"- , "true && false || false && true" -- should be same - , "(true && false) || (false && true)" -- as this- , "(os(darwin))"- , " ( os ( darwin ) ) "- , "true && !(false || os(plan9))"- , "flag( foo_bar )"- , "flag( foo_O_-_O_bar )"- , "impl ( ghc )"- , "impl( ghc >= 6.6.1 )"- ]--test_ppCondTree = render $ ppCondTree tstTree (text . show)- --test_simpCondTree = simplifyCondTree env tstTree- where- env x = maybe (Left x) Right (lookup x flags)- flags = [(mkFlag "a",False), (mkFlag "b",False), (mkFlag "c", True)] - mkFlag = Flag . ConfFlag--test_resolveWithFlags = resolveWithFlags dom "os" "arch" ("ghc",Version [6,6] []) [tstTree] check- where- dom = [("a", [False,True]), ("b", [True,False]), ("c", [True,False])]- check ds = let missing = ds \\ avail in- case missing of- [] -> DepOk- _ -> MissingDeps missing- avail = [0,1,3,4]--test_ignoreConditions = ignoreConditions tstTree--#endif
Distribution/GetOpt.hs view
@@ -122,8 +122,8 @@ fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _ ) so = "-" ++ [so]-fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad-fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"+fmtShort (ReqArg _ _) so = "-" ++ [so]+fmtShort (OptArg _ _) so = "-" ++ [so] fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _ ) lo = "--" ++ lo
Distribution/InstalledPackageInfo.hs view
@@ -46,7 +46,7 @@ -- This module is meant to be local-only to Distribution... module Distribution.InstalledPackageInfo (- InstalledPackageInfo(..),+ InstalledPackageInfo_(..), InstalledPackageInfo, ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, parseInstalledPackageInfo,@@ -56,15 +56,20 @@ import Distribution.ParseUtils ( FieldDescr(..), readFields, ParseResult(..), PError(..), PWarning,- Field(F), simpleField, listField, parseLicenseQ,+ Field(F), simpleField, listField, parseLicenseQ, ppField, ppFields, parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ,- showFilePath, showToken, parseReadS, parseOptVersion, parseQuoted,+ showFilePath, showToken, boolField, parseOptVersion, parseQuoted, showFreeText) import Distribution.License ( License(..) )-import Distribution.Package ( PackageIdentifier(..), showPackageId,- parsePackageId )-import Distribution.Version ( Version(..), showVersion )-import Distribution.Compat.ReadP as ReadP+import Distribution.Package+ ( PackageIdentifier(..), packageName, packageVersion )+import qualified Distribution.Package as Package+ ( Package(..), PackageFixedDeps(..) )+import Distribution.Version+ ( Version(..) )+import Distribution.Text+ ( Text(disp, parse) )+import qualified Distribution.Compat.ReadP as ReadP import Control.Monad ( foldM ) import Text.PrettyPrint@@ -72,7 +77,7 @@ -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type -data InstalledPackageInfo+data InstalledPackageInfo_ m = InstalledPackageInfo { -- these parts are exactly the same as PackageDescription package :: PackageIdentifier,@@ -87,8 +92,8 @@ category :: String, -- these parts are required by an installed package only: exposed :: Bool,- exposedModules :: [String],- hiddenModules :: [String],+ exposedModules :: [m],+ hiddenModules :: [m], importDirs :: [FilePath], -- contain sources in case of Hugs libraryDirs :: [FilePath], hsLibraries :: [String],@@ -107,7 +112,14 @@ } deriving (Read, Show) -emptyInstalledPackageInfo :: InstalledPackageInfo+instance Package.Package (InstalledPackageInfo_ str) where+ packageId = package+instance Package.PackageFixedDeps (InstalledPackageInfo_ str) where+ depends = depends++type InstalledPackageInfo = InstalledPackageInfo_ String++emptyInstalledPackageInfo :: InstalledPackageInfo_ m emptyInstalledPackageInfo = InstalledPackageInfo { package = PackageIdentifier "" noVersion,@@ -168,11 +180,7 @@ -- Pretty-printing showInstalledPackageInfo :: InstalledPackageInfo -> String-showInstalledPackageInfo pkg = render (ppFields all_fields)- where- ppFields [] = empty- ppFields ((FieldDescr name get' _):flds) = - pprField name (get' pkg) $$ ppFields flds+showInstalledPackageInfo pkg = render (ppFields pkg all_fields) showInstalledPackageInfoField :: String@@ -180,10 +188,7 @@ showInstalledPackageInfoField field = case [ (f,get') | (FieldDescr f get' _) <- all_fields, f == field ] of [] -> Nothing- ((f,get'):_) -> Just (render . pprField f . get')--pprField :: String -> Doc -> Doc-pprField name field = text name <> colon <+> field+ ((f,get'):_) -> Just (render . ppField f . get') -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing@@ -195,43 +200,45 @@ basicFieldDescrs = [ simpleField "name" text parsePackageNameQ- (pkgName . package) (\name pkg -> pkg{package=(package pkg){pkgName=name}})+ packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) , simpleField "version"- (text . showVersion) parseOptVersion - (pkgVersion . package) (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})+ disp parseOptVersion+ packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) , simpleField "license"- (text . show) parseLicenseQ+ disp parseLicenseQ license (\l pkg -> pkg{license=l}) , simpleField "copyright"- showFreeText (munch (const True))+ showFreeText parseFreeText copyright (\val pkg -> pkg{copyright=val}) , simpleField "maintainer"- showFreeText (munch (const True))+ showFreeText parseFreeText maintainer (\val pkg -> pkg{maintainer=val}) , simpleField "stability"- showFreeText (munch (const True))+ showFreeText parseFreeText stability (\val pkg -> pkg{stability=val}) , simpleField "homepage"- showFreeText (munch (const True))+ showFreeText parseFreeText homepage (\val pkg -> pkg{homepage=val}) , simpleField "package-url"- showFreeText (munch (const True))+ showFreeText parseFreeText pkgUrl (\val pkg -> pkg{pkgUrl=val}) , simpleField "description"- showFreeText (munch (const True))+ showFreeText parseFreeText description (\val pkg -> pkg{description=val}) , simpleField "category"- showFreeText (munch (const True))+ showFreeText parseFreeText category (\val pkg -> pkg{category=val}) , simpleField "author"- showFreeText (munch (const True))+ showFreeText parseFreeText author (\val pkg -> pkg{author=val}) ] +parseFreeText :: ReadP.ReadP s String+parseFreeText = ReadP.munch (const True)+ installedFieldDescrs :: [FieldDescr InstalledPackageInfo] installedFieldDescrs = [- simpleField "exposed"- (text.show) parseReadS+ boolField "exposed" exposed (\val pkg -> pkg{exposed=val}) , listField "exposed-modules" text parseModuleNameQ@@ -261,7 +268,7 @@ showFilePath parseFilePathQ includes (\xs pkg -> pkg{includes=xs}) , listField "depends"- (text.showPackageId) parsePackageId'+ disp parsePackageId' depends (\xs pkg -> pkg{depends=xs}) , listField "hugs-options" showToken parseTokenQ@@ -286,6 +293,5 @@ haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) ] -parsePackageId' :: ReadP [PackageIdentifier] PackageIdentifier-parsePackageId' = parseQuoted parsePackageId <++ parsePackageId-+parsePackageId' :: ReadP.ReadP [PackageIdentifier] PackageIdentifier+parsePackageId' = parseQuoted parse ReadP.<++ parse
Distribution/License.hs view
@@ -49,6 +49,13 @@ License(..) ) where +import Distribution.Version (Version)++import Distribution.Text (Text(..), display)+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import qualified Data.Char as Char (isAlphaNum)+ -- |This datatype indicates the license under which your package is -- released. It is also wise to add your license to each source file -- using the license-file field. The 'AllRightsReserved' constructor@@ -57,12 +64,69 @@ -- below are general guidelines. Please read the licenses themselves -- and consult a lawyer if you are unsure of your rights to release -- the software.+--+data License = -data License = GPL -- ^GNU Public License. Source code must accompany alterations.- | LGPL -- ^Lesser GPL, Less restrictive than GPL, useful for libraries.- | BSD3 -- ^3-clause BSD license, newer, no advertising clause. Very free license.- | BSD4 -- ^4-clause BSD license, older, with advertising clause.- | PublicDomain -- ^Holder makes no claim to ownership, least restrictive license.- | AllRightsReserved -- ^No rights are granted to others. Undistributable. Most restrictive.- | {- ... | -} OtherLicense -- ^Some other license.- deriving (Read, Show, Eq)+--TODO: * deprecate BSD4+-- * add optional gpl versions+-- * add MIT license++ -- | GNU Public License. Source code must accompany alterations.+ GPL --(Maybe Version)++ -- | Lesser GPL, Less restrictive than GPL, useful for libraries.+ | LGPL --(Maybe Version)++ -- | 3-clause BSD license, newer, no advertising clause. Very free license.+ | BSD3++ -- | 4-clause BSD license, older, with advertising clause.+ | BSD4++-- -- | The MIT license, similar to the BSD3. Very free license.+-- | MIT++ -- | Holder makes no claim to ownership, least restrictive license.+ | PublicDomain++ -- | No rights are granted to others. Undistributable. Most restrictive.+ | AllRightsReserved++ -- | Some other license.+ | OtherLicense++ -- | Not a recognised license.+ -- Allows us to deal with future extensions more gracefully.+ | UnknownLicense String+ deriving (Read, Show, Eq)++--TODO: use knownLicenses to give a better parse error message+--knownLicenses :: [License]+--knownLicenses = [GPL Nothing, LGPL Nothing, BSD3, BSD4, MIT+-- ,PublicDomain, AllRightsReserved, OtherLicense]++instance Text License where+--disp (GPL version) = "GPL" <> showOptionalVersion version+--disp (LGPL version) = "LGPL" <> showOptionalVersion version+ disp (UnknownLicense other) = Disp.text other+ disp other = Disp.text (show other)++ parse = do+ 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+ -- for when we do introduce optional (L)GPL license versions.+ return $ case (name, version :: Maybe Version) of+ ("GPL", Nothing) -> GPL+ ("LGPL", Nothing) -> LGPL+ -- ("GPL", version) -> GPL version+ -- ("LGPL", version) -> LGPL version+ ("BSD3", Nothing) -> BSD3+ ("BSD4", Nothing) -> BSD4+ -- ("MIT", Nothing) -> MIT+ ("PublicDomain", Nothing) -> PublicDomain+ ("AllRightsReserved", Nothing) -> AllRightsReserved+ ("OtherLicense", Nothing) -> OtherLicense+ _ -> UnknownLicense $ name+ ++ maybe "" (('-':) . display) version
Distribution/Make.hs view
@@ -39,8 +39,6 @@ -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target.--- --- [ProgramaticaCmd] We assume there is a @programatica@ target. -- copy :@@ -88,125 +86,121 @@ import Distribution.Simple.Program(defaultProgramConfiguration) import Distribution.PackageDescription import Distribution.Simple.Setup+import Distribution.Simple.Command -import Distribution.Simple.Utils (die, maybeExit)+import Distribution.Simple.Utils (rawSystemExit, cabalVersion) import Distribution.License (License(..))-import Distribution.Version (Version(..))-import Distribution.Verbosity+import Distribution.Version+ ( Version(..) )+import Distribution.Text+ ( display ) -import System.Environment(getArgs)-import Data.List ( intersperse )-import System.Cmd+import System.Environment (getArgs, getProgName)+import Data.List (intersperse) import System.Exit -exec :: String -> IO ExitCode-exec cmd = (putStrLn $ "-=-= Cabal executing: " ++ cmd ++ "=-=-")- >> system cmd- defaultMain :: IO () defaultMain = getArgs >>= defaultMainArgs defaultMainArgs :: [String] -> IO ()-defaultMainArgs args =- defaultMainHelper args $ \ _verbosity ->- error "Package Descripion was promised not be used here"- --defaultPackageDesc verbosity >>=- -- readPackageDescription verbosity +defaultMainArgs = defaultMainHelper +{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} defaultMainNoRead :: PackageDescription -> IO ()-defaultMainNoRead pkg_descr = do- args <- getArgs- defaultMainHelper args $ \ _ -> return pkg_descr --defaultMainHelper :: [String] -> (Verbosity -> IO PackageDescription) -> IO ()-defaultMainHelper globalArgs _get_pkg_descr- = do (action, args) <- parseGlobalArgs defaultProgramConfiguration globalArgs- case action of- ConfigCmd flags -> do- (configFlags, _, extraArgs) <- parseConfigureArgs defaultProgramConfiguration flags args []- retVal <- exec $ unwords $- "./configure" : configureArgs configFlags ++ extraArgs- if (retVal == ExitSuccess)- then putStrLn "Configure Succeeded."- else putStrLn "Configure failed."- exitWith retVal+defaultMainNoRead = const defaultMain - CopyCmd copydest0 -> do- ((CopyFlags copydest _), _, extraArgs) <- parseCopyArgs (CopyFlags copydest0 normal) args []- no_extra_flags extraArgs- let cmd = case copydest of - NoCopyDest -> "install"- CopyTo path -> "copy destdir=" ++ path- CopyPrefix path -> "install prefix=" ++ path- -- CopyPrefix is backwards compat, DEPRECATED- maybeExit $ system $ ("make " ++ cmd)+defaultMainHelper :: [String] -> IO ()+defaultMainHelper args =+ case commandsRun globalCommand commands args of+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo (flags, commandParse) ->+ case commandParse of+ _ | fromFlag (globalVersion flags) -> printVersion+ | fromFlag (globalNumericVersion flags) -> printNumericVersion+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo action -> action - InstallCmd -> do- ((InstallFlags _ _), _, extraArgs) <- parseInstallArgs emptyInstallFlags args []- no_extra_flags extraArgs- maybeExit $ system $ "make install"- retVal <- exec "make register"- if (retVal == ExitSuccess)- then putStrLn "Install Succeeded."- else putStrLn "Install failed."- exitWith retVal+ where+ printHelp help = getProgName >>= putStr . help+ printOptionsList = putStr . unlines+ printErrors errs = do+ putStr (concat (intersperse "\n" errs))+ exitWith (ExitFailure 1)+ printNumericVersion = putStrLn $ display cabalVersion+ printVersion = putStrLn $ "Cabal library version "+ ++ display cabalVersion - HaddockCmd -> do - (_, _, extraArgs) <- parseHaddockArgs emptyHaddockFlags args []- no_extra_flags extraArgs- retVal <- exec "make docs"- case retVal of- ExitSuccess -> do putStrLn "Haddock Succeeded"- exitWith ExitSuccess- _ -> do retVal' <- exec "make doc"- case retVal' of- ExitSuccess -> do putStrLn "Haddock Succeeded"- exitWith ExitSuccess- _ -> do putStrLn "Haddock Failed."- exitWith retVal'+ progs = defaultProgramConfiguration+ commands =+ [configureCommand progs `commandAddAction` configureAction+ ,buildCommand progs `commandAddAction` buildAction+ ,installCommand `commandAddAction` installAction+ ,copyCommand `commandAddAction` copyAction+ ,haddockCommand `commandAddAction` haddockAction+ ,cleanCommand `commandAddAction` cleanAction+ ,sdistCommand `commandAddAction` sdistAction+ ,registerCommand `commandAddAction` registerAction+ ,unregisterCommand `commandAddAction` unregisterAction+ ] - BuildCmd -> basicCommand "Build" "make"- (parseBuildArgs defaultProgramConfiguration- (emptyBuildFlags defaultProgramConfiguration)- args [])+configureAction :: ConfigFlags -> [String] -> IO ()+configureAction flags args = do+ noExtraFlags args+ let verbosity = fromFlag (configVerbosity flags)+ rawSystemExit verbosity "sh" $+ "configure"+ : configureArgs backwardsCompatHack flags+ where backwardsCompatHack = True - MakefileCmd -> exitWith ExitSuccess -- presumably nothing to do+copyAction :: CopyFlags -> [String] -> IO ()+copyAction flags args = do+ noExtraFlags args+ let destArgs = case fromFlag $ copyDest' flags of+ NoCopyDest -> ["install"]+ CopyTo path -> ["copy", "destdir=" ++ path]+ CopyPrefix path -> ["install", "prefix=" ++ path]+ -- CopyPrefix is backwards compat, DEPRECATED+ rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs - CleanCmd -> basicCommand "Clean" "make clean"- (parseCleanArgs emptyCleanFlags args [])+installAction :: InstallFlags -> [String] -> IO ()+installAction flags args = do+ noExtraFlags args+ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]+ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] - SDistCmd -> basicCommand "SDist" "make dist" (parseSDistArgs args [])+haddockAction :: HaddockFlags -> [String] -> IO ()+haddockAction flags args = do + noExtraFlags args+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]+ `catch` \_ ->+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] - RegisterCmd -> basicCommand "Register" "make register"- (parseRegisterArgs emptyRegisterFlags args [])+buildAction :: BuildFlags -> [String] -> IO ()+buildAction flags args = do+ noExtraFlags args+ rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] - UnregisterCmd -> basicCommand "Unregister" "make unregister"- (parseUnregisterArgs emptyRegisterFlags args [])- ProgramaticaCmd -> basicCommand "Programatica" "make programatica"- (parseProgramaticaArgs args [])+cleanAction :: CleanFlags -> [String] -> IO ()+cleanAction flags args = do+ noExtraFlags args+ rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] - HelpCmd -> exitWith ExitSuccess -- this is handled elsewhere- - _ -> do putStrLn "Command not implemented for makefiles."- exitWith (ExitFailure 1)+sdistAction :: SDistFlags -> [String] -> IO ()+sdistAction flags args = do+ noExtraFlags args+ rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] --- |convinience function for repetitions above-basicCommand :: String -- ^Command name- -> String -- ^Command command- -> (IO (b, [a], [String])) -- ^Command parser function- -> IO ()-basicCommand commandName commandCommand commandParseFun = do - (_, _, args) <- commandParseFun- no_extra_flags args- retVal <- exec commandCommand- putStrLn $ commandName ++ - if (retVal == ExitSuccess)- then " Succeeded."- else " Failed."- exitWith retVal+registerAction :: RegisterFlags -> [String] -> IO ()+registerAction flags args = do+ noExtraFlags args+ rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] -no_extra_flags :: [String] -> IO ()-no_extra_flags [] = return ()-no_extra_flags extra_flags = - die $ "Unrecognised flags: " ++ concat (intersperse "," (extra_flags))+unregisterAction :: RegisterFlags -> [String] -> IO ()+unregisterAction flags args = do+ noExtraFlags args+ rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
Distribution/Package.hs view
@@ -40,13 +40,32 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Package (+ -- * Package ids PackageIdentifier(..),- showPackageId, parsePackageId, parsePackageName,+ parsePackageName,++ -- * Package dependencies+ Dependency(..),+ thisPackageVersion,+ notThisPackageVersion,++ -- * Package classes+ Package(..), packageName, packageVersion,+ PackageFixedDeps(..),++ -- * Deprecated compat stuff+ showPackageId, ) where import Distribution.Version-import Distribution.Compat.ReadP as ReadP-import Data.Char ( isDigit, isAlphaNum )+ ( Version(..), VersionRange(AnyVersion,ThisVersion), notThisVersion )++import Distribution.Text (Text(..), display)+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, isAlphaNum ) import Data.List ( intersperse ) -- | The name and version of a package.@@ -57,24 +76,81 @@ } deriving (Read, Show, Eq, Ord) --- |Creates a string like foo-1.2-showPackageId :: PackageIdentifier -> String-showPackageId (PackageIdentifier n (Version [] _)) = n -- if no version, don't show version.-showPackageId pkgid = - pkgName pkgid ++ '-': showVersion (pkgVersion pkgid)+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 -parsePackageName :: ReadP r String-parsePackageName = do ns <- sepBy1 component (char '-')+ parse = do+ n <- parsePackageName+ 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 <- munch1 isAlphaNum- if all isDigit cs then pfail else return cs+ 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). --- |A package ID looks like foo-1.2.-parsePackageId :: ReadP r PackageIdentifier-parsePackageId = do - n <- parsePackageName- v <- (ReadP.char '-' >> parseVersion) <++ return (Version [] [])- return PackageIdentifier{pkgName=n,pkgVersion=v}+-- ------------------------------------------------------------+-- * Package dependencies+-- ------------------------------------------------------------++data Dependency = Dependency String VersionRange+ deriving (Read, Show, Eq)++instance Text Dependency where+ disp (Dependency name ver) =+ Disp.text name <+> disp ver++ parse = do name <- parsePackageName+ Parse.skipSpaces+ ver <- parse <++ return AnyVersion+ Parse.skipSpaces+ return (Dependency name ver)++thisPackageVersion :: PackageIdentifier -> Dependency+thisPackageVersion (PackageIdentifier n v) =+ Dependency n (ThisVersion v)++notThisPackageVersion :: PackageIdentifier -> Dependency+notThisPackageVersion (PackageIdentifier n v) =+ Dependency n (notThisVersion v)++-- | Class of things that can be identified by a 'PackageIdentifier'+--+-- Types in this class are all notions of a package. This allows us to have+-- different types for the different phases that packages go though, from+-- simple name\/id, package description, configured or installed packages.+--+class Package pkg where+ packageId :: pkg -> PackageIdentifier++packageName :: Package pkg => pkg -> String+packageName = pkgName . packageId++packageVersion :: Package pkg => pkg -> Version+packageVersion = pkgVersion . packageId++instance Package PackageIdentifier where+ packageId = id++-- | Subclass of packages that have specific versioned dependencies.+--+-- So for example a not-yet-configured package has dependencies on version+-- ranges, not specific versions. A configured or an already installed package+-- depends on exact versions. Some operations or data structures (like+-- dependency graphs) only make sense on this subclass of package types.+--+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
@@ -1,1679 +1,1330 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- 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(..),- finalizePackageDescription,- flattenPackageDescription,- emptyPackageDescription,- readPackageDescription,- writePackageDescription,- parsePackageDescription,- showPackageDescription,- BuildType(..),-- -- ** Libraries- Library(..),- withLib,- hasLibs,- libModules,-- -- ** Executables- Executable(..),- withExe,- hasExes,- exeModules,-- -- ** Parsing- FieldDescr(..),- LineNo,-- -- ** Sanity checking- sanityCheckPackage,-- -- * Build information- BuildInfo(..),- emptyBuildInfo,- allBuildInfo,-- -- ** Supplementary build information- HookedBuildInfo,- emptyHookedBuildInfo,- readHookedBuildInfo,- parseHookedBuildInfo,- writeHookedBuildInfo,- showHookedBuildInfo, - updatePackageDescription,-- -- * Utilities- satisfyDependency,- ParseResult(..),- hcOptions,- autogenModuleName,- haddockName,- setupMessage,- cabalVersion,--#ifdef DEBUG- -- * Debugging- hunitTests,- test-#endif- ) where--import Control.Monad(liftM, foldM, when, unless)-import Data.Char-import Data.Maybe(isNothing, isJust, catMaybes, listToMaybe, maybeToList)-import Data.List (nub, maximumBy, unfoldr, partition)-import Text.PrettyPrint.HughesPJ as Pretty-import System.Directory(doesFileExist)--import Distribution.ParseUtils-import Distribution.Package(PackageIdentifier(..),showPackageId,- parsePackageName)-import Distribution.Version(Version(..), VersionRange(..), withinRange,- showVersion, parseVersion, showVersionRange,- parseVersionRange, isAnyVersion)-import Distribution.License(License(..))-import Distribution.Version(Dependency(..))-import Distribution.Verbosity-import Distribution.Compiler(CompilerFlavor(..))-import Distribution.Configuration-import Distribution.Simple.Utils(currentDir, die, dieWithLocation, warn, notice)-import Language.Haskell.Extension(Extension(..))--import Distribution.Compat.ReadP as ReadP hiding (get)-import System.FilePath((<.>), takeExtension)--import Data.Monoid--#ifdef DEBUG-import Data.List ( sortBy )-import Test.HUnit (Test(..), assertBool, Assertion, runTestTT, Counts, assertEqual)-#endif---- We only get our own version number when we're building with ourselves-cabalVersion :: Version-#ifdef CABAL_VERSION-cabalVersion = Version [CABAL_VERSION] []-#else-cabalVersion = error "Cabal was not bootstrapped correctly"-#endif---- -------------------------------------------------------------------------------- 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,- buildDepends :: [Dependency],- descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here.- buildType :: BuildType,- -- components- library :: Maybe Library,- executables :: [Executable],- dataFiles :: [FilePath],- extraSrcFiles :: [FilePath],- extraTmpFiles :: [FilePath]- }- deriving (Show, Read, Eq)--emptyPackageDescription :: PackageDescription-emptyPackageDescription- = PackageDescription {package = PackageIdentifier "" (Version [] []),- license = AllRightsReserved,- licenseFile = "",- descCabalVersion = AnyVersion,- buildType = Custom,- copyright = "",- maintainer = "",- author = "",- stability = "",- testedWith = [],- buildDepends = [],- homepage = "",- pkgUrl = "",- synopsis = "",- description = "",- category = "",- library = Nothing,- executables = [],- dataFiles = [],- extraSrcFiles = [],- extraTmpFiles = []- }--data GenericPackageDescription = - GenericPackageDescription {- packageDescription :: PackageDescription,- genPackageFlags :: [Flag],- condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),- condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)]- }- --deriving (Show)---- 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--data PDTagged = Lib Library | Exe String Executable | PDNull--instance Monoid PDTagged where- mempty = PDNull- PDNull `mappend` x = x- x `mappend` PDNull = x- Lib l `mappend` Lib l' = Lib (l `mappend` l')- Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')- _ `mappend` _ = bug "Cannot combine incompatible tags"--finalizePackageDescription - :: [(String,Bool)] -- ^ Explicitly specified flag assignments- -> Maybe [PackageIdentifier] -- ^ Available dependencies. Pass 'Nothing' if this- -- is unknown.- -> String -- ^ OS-name- -> String -- ^ Arch-name- -> (String, Version) -- ^ Compiler + Version- -> GenericPackageDescription- -> Either [Dependency]- (PackageDescription, [(String,Bool)])- -- ^ Either missing dependencies or the resolved package- -- description along with the flag assignments chosen.-finalizePackageDescription userflags mpkgs os arch impl - (GenericPackageDescription pkg flags mlib0 exes0) =- case resolveFlags of - Right ((mlib, exes'), deps, flagVals) ->- Right ( pkg { library = mlib - , executables = exes'- , buildDepends = nub deps- }- , flagVals )- Left missing -> Left $ nub missing- where- -- Combine lib and exes into one list of @CondTree@s with tagged data- condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )- ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0-- untagRslts = foldr untag (Nothing, [])- where- untag (Lib _) (Just _, _) = bug "Only one library expected"- untag (Lib l) (Nothing, exes) = (Just l, exes)- untag (Exe n e) (mlib, exes)- | any ((== n) . fst) exes = bug "Exe with same name found"- | otherwise = (mlib, exes ++ [(n, e)])- untag PDNull x = x -- actually this should not happen, but let's be liberal-- resolveFlags =- case resolveWithFlags flagChoices os arch impl condTrees check of- Right (as, ds, fs) ->- let (mlib, exes) = untagRslts as in- Right ( (fmap libFillInDefaults mlib,- map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes),- 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- --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = if all satisfyDep ds- then DepOk- else MissingDeps $ filter (not . satisfyDep) ds- -- if we don't know which packages are present, we just accept any- -- dependency- satisfyDep = maybe (const True) - (\pkgs -> isJust . satisfyDependency pkgs) - mpkgs----- | Flatten a generic package description by ignoring all conditions and just--- join the field descriptors into on package description. Note, however,--- that this may lead to inconsistent field values, since all values are--- joined into one field, which may not be possible in the original package--- description, due to the use of exclusive choices (if ... else ...).------ XXX: One particularly tricky case is defaulting. In the original package--- description, e.g., the source dirctory might either be the default or a--- certain, explicitly set path. Since defaults are filled in only after the--- package has been resolved and when no explicit value has been set, the--- default path will be missing from the package description returned by this--- function.-flattenPackageDescription :: GenericPackageDescription -> PackageDescription-flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0) =- pkg { library = mlib- , executables = reverse exes- , buildDepends = nub $ ldeps ++ reverse edeps- }- where- (mlib, ldeps) = case mlib0 of- Just lib -> let (l,ds) = ignoreConditions lib in - (Just (libFillInDefaults l), ds)- Nothing -> (Nothing, [])- (exes, edeps) = foldr flattenExe ([],[]) exes0- flattenExe (n, t) (es, ds) = - let (e, ds') = ignoreConditions t in- ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) ----- | 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)- deriving (Show, Read, Eq)---- the strings for the required fields are necessary here, and so we--- don't repeat ourselves, I name them:-reqNameName :: String-reqNameName = "name"-reqNameVersion :: String-reqNameVersion = "version"-reqNameCopyright :: String-reqNameCopyright = "copyright"-reqNameMaintainer :: String-reqNameMaintainer = "maintainer"-reqNameSynopsis :: String-reqNameSynopsis = "synopsis"--pkgDescrFieldDescrs :: [FieldDescr PackageDescription]-pkgDescrFieldDescrs =- [ simpleField reqNameName- text parsePackageName- (pkgName . package) (\name pkg -> pkg{package=(package pkg){pkgName=name}})- , simpleField reqNameVersion- (text . showVersion) parseVersion- (pkgVersion . package) (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})- , simpleField "cabal-version"- (text . showVersionRange) parseVersionRange- descCabalVersion (\v pkg -> pkg{descCabalVersion=v})- , simpleField "build-type"- (text . show) parseReadSQ- buildType (\t pkg -> pkg{buildType=t})- , simpleField "license"- (text . show) parseLicenseQ- license (\l pkg -> pkg{license=l})- , simpleField "license-file"- showFilePath parseFilePathQ- licenseFile (\l pkg -> pkg{licenseFile=l})- , simpleField reqNameCopyright- showFreeText (munch (const True))- copyright (\val pkg -> pkg{copyright=val})- , simpleField reqNameMaintainer- showFreeText (munch (const True))- maintainer (\val pkg -> pkg{maintainer=val})- , commaListField "build-depends"- showDependency parseDependency- buildDepends (\xs pkg -> pkg{buildDepends=xs})- , simpleField "stability"- showFreeText (munch (const True))- stability (\val pkg -> pkg{stability=val})- , simpleField "homepage"- showFreeText (munch (const True))- homepage (\val pkg -> pkg{homepage=val})- , simpleField "package-url"- showFreeText (munch (const True))- pkgUrl (\val pkg -> pkg{pkgUrl=val})- , simpleField reqNameSynopsis- showFreeText (munch (const True))- synopsis (\val pkg -> pkg{synopsis=val})- , simpleField "description"- showFreeText (munch (const True))- description (\val pkg -> pkg{description=val})- , simpleField "category"- showFreeText (munch (const True))- category (\val pkg -> pkg{category=val})- , simpleField "author"- showFreeText (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})- , listField "extra-source-files" - showFilePath parseFilePathQ- extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})- , listField "extra-tmp-files" - showFilePath parseFilePathQ- extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})- ]---- ------------------------------------------------------------------------------ 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 -> toMaybe (buildable (libBuildInfo lib)) lib)---- |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--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})--unionLibrary :: Library -> Library -> Library-unionLibrary l1 l2 =- l1 { exposedModules = combine exposedModules- , libBuildInfo = unionBuildInfo (libBuildInfo l1) (libBuildInfo l2)- }- where combine f = f l1 ++ f l2---- This is in fact rather a hack. The original version just overrode the--- default values, however, when adding conditions we had to switch to a--- modifier-based approach. There, nothing is ever overwritten, but only--- joined together.------ This is the cleanest way i could think of, that doesn't require--- changing all field parsing functions to return modifiers instead.-libFillInDefaults :: Library -> Library-libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi }---- ------------------------------------------------------------------------------ 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 }---- note comment at libFillInDefaults-exeFillInDefaults :: Executable -> Executable-exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi }---- |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--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})--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]- }- deriving (Show,Read,Eq)--nullBuildInfo :: BuildInfo-nullBuildInfo = BuildInfo {- buildable = True,- buildTools = [],- cppOptions = [],- ccOptions = [],- ldOptions = [],- pkgconfigDepends = [],- frameworks = [],- cSources = [],- hsSourceDirs = [],- otherModules = [],- extensions = [],- extraLibs = [],- extraLibDirs = [],- includeDirs = [],- includes = [],- installIncludes = [],- options = [],- ghcProfOptions = [],- ghcSharedOptions = []- }--emptyBuildInfo :: BuildInfo-emptyBuildInfo = nullBuildInfo { hsSourceDirs = [currentDir] }---- | 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 ]---- see comment at libFillInDefaults-biFillInDefaults :: BuildInfo -> BuildInfo-biFillInDefaults bi =- if null (hsSourceDirs bi)- then bi { hsSourceDirs = [currentDir] }- else bi--type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])--emptyHookedBuildInfo :: HookedBuildInfo-emptyHookedBuildInfo = (Nothing, [])--binfoFieldDescrs :: [FieldDescr BuildInfo]-binfoFieldDescrs =- [ simpleField "buildable"- (text . show) parseReadS- buildable (\val binfo -> binfo{buildable=val})- , commaListField "build-tools"- showDependency parseDependency- 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"- showDependency 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"- (text . show) 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})- ]----------------------------------------------------------------------------------flagFieldDescrs :: [FieldDescr Flag]-flagFieldDescrs =- [ simpleField "description"- showFreeText (munch (const True))- flagDescription (\val fl -> fl{ flagDescription = val })- , simpleField "default"- (text . show) parseReadS- flagDefault (\val fl -> fl{ flagDefault = val })- ]---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------satisfyDependency :: [PackageIdentifier] -> Dependency- -> Maybe PackageIdentifier-satisfyDependency pkgs (Dependency pkgname vrange) =- case filter ok pkgs of- [] -> Nothing - qs -> Just (maximumBy versions qs)- where- ok p = pkgName p == pkgname && pkgVersion p `withinRange` vrange- versions a b = pkgVersion a `compare` pkgVersion b---- |Update the given package description with the output from the--- pre-hooks.--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- = b1{buildable = buildable b1 && buildable b2,- buildTools = combine buildTools,- cppOptions = combine cppOptions,- ccOptions = combine ccOptions,- ldOptions = combine ldOptions,- pkgconfigDepends = combine pkgconfigDepends,- frameworks = combine frameworks,- cSources = combine cSources,- hsSourceDirs = combine hsSourceDirs,- otherModules = combine otherModules,- extensions = combine extensions,- extraLibs = combine extraLibs,- extraLibDirs = combine extraLibDirs,- includeDirs = combine includeDirs,- includes = combine includes,- installIncludes = combine installIncludes,- options = combine options- }- where - combine :: (Eq a) => (BuildInfo -> [a]) -> [a]- combine f = nub $ f b1 ++ f b2---- |Select options for a particular Haskell compiler.-hcOptions :: CompilerFlavor -> [(CompilerFlavor, [String])] -> [String]-hcOptions hc hc_opts = [opt | (hc',opts) <- hc_opts, hc' == hc, opt <- opts]---- |The name of the auto-generated module associated with a package-autogenModuleName :: PackageDescription -> String-autogenModuleName pkg_descr =- "Paths_" ++ map fixchar (pkgName (package pkg_descr))- where fixchar '-' = '_'- fixchar c = c--haddockName :: PackageDescription -> FilePath-haddockName pkg_descr = pkgName (package pkg_descr) <.> "haddock"--setupMessage :: Verbosity -> String -> PackageDescription -> IO ()-setupMessage verbosity msg pkg_descr =- notice verbosity (msg ++ ' ':showPackageId (package pkg_descr) ++ "...")---- ------------------------------------------------------------------ Parsing---- | Given a parser and a filename, return the parse of the file,--- after checking if the file exists.-readAndParseFile :: Verbosity -> (String -> ParseResult a) -> FilePath -> IO a-readAndParseFile verbosity parser 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 ws x -> do- mapM_ (warn verbosity) (reverse ws)- return x--readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-readHookedBuildInfo verbosity = readAndParseFile verbosity parseHookedBuildInfo---- |Parse the given package file.-readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription-readPackageDescription verbosity =- readAndParseFile verbosity 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 parseDependency) 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 sf = sectionizeFields fields0- fields <- mapSimpleFields deprecField sf-- flip evalStT fields $ do- hfs <- getHeader []- pkg <- lift $ parseFields pkgDescrFieldDescrs emptyPackageDescription hfs- (flags, mlib, exes) <- getBody- warnIfRest- when (not (oldSyntax fields0)) $- maybeWarnCabalVersion pkg- 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 (pkgName (package 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."-- -- "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 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 - (MkFlag (map toLower 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- unless (null subSects) $- lift $ warning $ "Unknown section types: " ++ show (map fName subSects)- ++ "\n Probable cause: missing colon after field name, or newer Cabal version required"- 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, cplxFlds) = partition isSimple allflds- (condFlds, subSects) = partition isCond cplxFlds- isSimple (F _ _ _) = True- isSimple _ = False- isCond (IfBlock _ _ _ _) = True- isCond _ = False- 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 nullLibrary -- parseExeFields :: [Field] -> StT s ParseResult Executable- parseExeFields = lift . parseFields executableFieldDescrs nullExecutable---parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a-parseFields descrs ini fields = - do (a, unknowns) <- foldM (parseField descrs) (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] -> (a,[(Int,String)]) -> Field -> ParseResult (a, [(Int,String)])-parseField ((FieldDescr name _ parse):fields) (a, us) (F line f val)- | name == f = parse line val a >>= \a' -> return (a',us)- | otherwise = parseField fields (a,us) (F line f val)--- ignore "x-" extension fields without a warning-parseField [] (a,us) (F _ ('x':'-':_) _) = return (a, us)-parseField [] (a,us) (F l f _) = do- return (a, ((l,f):us))-parseField _ _ _ = error "'parseField' called on a non-field. This is a bug."--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 _ = error "'deprecField' called on a non-field. This is a bug."-- -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 _):_))- | map toLower inFieldName /= "executable" = liftM Just (parseBI bi)- parseLib _ = return Nothing-- parseExe :: [Field] -> ParseResult (String, BuildInfo)- parseExe ((F line inFieldName mName):bi)- | map toLower inFieldName == "executable"- = do bis <- parseBI bi- return (mName, bis)- | otherwise = syntaxError line "expecting 'executable' at top of stanza"- parseExe (_:_) = error "`parseExe' called on a non-field. This is a bug."- parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"-- parseBI st = parseFields binfoFieldDescrs emptyBuildInfo st---- ------------------------------------------------------------------------------ Pretty printing--writePackageDescription :: FilePath -> PackageDescription -> IO ()-writePackageDescription fpath pkg = writeFile fpath (showPackageDescription pkg)--showPackageDescription :: PackageDescription -> String-showPackageDescription pkg = render $- ppFields pkg pkgDescrFieldDescrs $$- (case library pkg of- Nothing -> empty- Just lib -> ppFields lib libFieldDescrs) $$- vcat (map ppExecutable (executables pkg))- where- ppExecutable exe = space $$ ppFields exe executableFieldDescrs--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--ppFields :: a -> [FieldDescr a] -> Doc-ppFields _ [] = empty-ppFields pkg' ((FieldDescr name getter _):flds) =- ppField name (getter pkg') $$ ppFields pkg' flds--ppField :: String -> Doc -> Doc-ppField name fielddoc = text name <> colon <+> fielddoc---- 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)--#ifdef DEBUG-test_findIndentTabs = findIndentTabs $ unlines $- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]-#endif---- --------------------------------------------------------------- * Sanity Checking--- ---------------------------------------------------------------- |Sanity check this description file.---- FIX: add a sanity check for missing haskell files? That's why its--- in the IO monad.--sanityCheckPackage :: PackageDescription -> IO ([String] -- Warnings- ,[String])-- Errors-sanityCheckPackage pkg_descr = - let libSane = sanityCheckLib (library pkg_descr)- nothingToDo = checkSanity- (null (executables pkg_descr) - && isNothing (library pkg_descr))- "No executables and no library found. Nothing to do."- noModules = checkSanity (hasMods pkg_descr)- "No exposed modules or executables in this package."- noLicenseFile = checkSanity (null $ licenseFile pkg_descr)- "No license-file field."- goodCabal = let v = (descCabalVersion pkg_descr)- in checkSanity (not $ cabalVersion `withinRange` v)- ("This package requires Cabal version: " - ++ (showVersionRange v) ++ ".")- in return $ ( catMaybes [nothingToDo, noModules, noLicenseFile],- catMaybes (libSane:goodCabal: checkMissingFields pkg_descr- ++ map sanityCheckExe (executables pkg_descr)) )--toMaybe :: Bool -> a -> Maybe a-toMaybe b x = if b then Just x else Nothing--checkMissingFields :: PackageDescription -> [Maybe String]-checkMissingFields pkg_descr = - [missingField (pkgName . package) reqNameName- ,missingField (versionBranch .pkgVersion .package) reqNameVersion- ]- where missingField :: (PackageDescription -> [a]) -- Field accessor- -> String -- Name of field- -> Maybe String -- error message- missingField f n- = toMaybe (null (f pkg_descr)) ("Missing field: " ++ n)--sanityCheckLib :: Maybe Library -> Maybe String-sanityCheckLib ml = do- l <- ml- toMaybe (buildable (libBuildInfo l) && null (exposedModules l)) $- "A library was specified, but no exposed modules list has been given.\n"- ++ "Fields of the library section:\n"- ++ (render $ nest 4 $ ppFields l libFieldDescrs )- --sanityCheckExe :: Executable -> Maybe String-sanityCheckExe exe- | null (modulePath exe)- = Just ("No 'Main-Is' field found for executable " ++ exeName exe- ++ "Fields of the executable section:\n"- ++ (render $ nest 4 $ ppFields exe executableFieldDescrs))- | ext `notElem` [".hs", ".lhs"]- = Just ("The 'Main-Is' field must specify a '.hs' or '.lhs' file\n"- ++" (even if it is generated by a preprocessor).")- | otherwise = Nothing- where ext = takeExtension (modulePath exe)--checkSanity :: Bool -> String -> Maybe String-checkSanity = toMaybe--hasMods :: PackageDescription -> Bool-hasMods pkg_descr =- null (executables pkg_descr) &&- maybe True (null . exposedModules) (library pkg_descr)--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."----- --------------------------------------------------------------- * Testing--- -------------------------------------------------------------#ifdef DEBUG--compatTestPkgDesc :: String-compatTestPkgDesc = unlines [- "-- Required",- "Name: Cabal",- "Version: 0.1.1.1.1-rain",- "License: LGPL",- "License-File: foo",- "Copyright: Free Text String",- "Cabal-version: >1.1.1",- "-- Optional - may be in source?",- "Author: Happy Haskell Hacker",- "Homepage: http://www.haskell.org/foo",- "Package-url: http://www.haskell.org/foo",- "Synopsis: a nice package!",- "Description: a really nice package!",- "Category: tools",- "buildable: True",- "CC-OPTIONS: -g -o",- "LD-OPTIONS: -BStatic -dn",- "Frameworks: foo",- "Tested-with: GHC",- "Stability: Free Text String",- "Build-Depends: haskell-src, HUnit>=1.0.0-rain",- "Other-Modules: Distribution.Package, Distribution.Version,",- " Distribution.Simple.GHCPackageConfig",- "Other-files: file1, file2",- "Extra-Tmp-Files: file1, file2",- "C-Sources: not/even/rain.c, such/small/hands",- "HS-Source-Dirs: src, src2",- "Exposed-Modules: Distribution.Void, Foo.Bar",- "Extensions: OverlappingInstances, TypeSynonymInstances",- "Extra-Libraries: libfoo, bar, bang",- "Extra-Lib-Dirs: \"/usr/local/libs\"",- "Include-Dirs: your/slightest, look/will",- "Includes: /easily/unclose, /me, \"funky, path\\\\name\"",- "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"",- "GHC-Options: -fTH -fglasgow-exts",- "Hugs-Options: +TH",- "Nhc-Options: ",- "Jhc-Options: ",- "",- "-- Next is an executable",- "Executable: somescript",- "Main-is: SomeFile.hs",- "Other-Modules: Foo1, Util, Main",- "HS-Source-Dir: scripts",- "Extensions: OverlappingInstances",- "GHC-Options: ",- "Hugs-Options: ",- "Nhc-Options: ",- "Jhc-Options: "- ]--compatTestPkgDescAnswer :: PackageDescription-compatTestPkgDescAnswer = - PackageDescription - { package = PackageIdentifier - { pkgName = "Cabal",- pkgVersion = Version {versionBranch = [0,1,1,1,1],- versionTags = ["rain"]}},- license = LGPL,- licenseFile = "foo",- copyright = "Free Text String",- author = "Happy Haskell Hacker",- homepage = "http://www.haskell.org/foo",- pkgUrl = "http://www.haskell.org/foo",- synopsis = "a nice package!",- description = "a really nice package!",- category = "tools",- descCabalVersion = LaterVersion (Version [1,1,1] []),- buildType = Custom,- buildDepends = [Dependency "haskell-src" AnyVersion,- Dependency "HUnit"- (UnionVersionRanges - (ThisVersion (Version [1,0,0] ["rain"]))- (LaterVersion (Version [1,0,0] ["rain"])))],- testedWith = [(GHC, AnyVersion)],- maintainer = "",- stability = "Free Text String",- extraTmpFiles = ["file1", "file2"],- extraSrcFiles = ["file1", "file2"],- dataFiles = [],-- library = Just $ Library {- exposedModules = ["Distribution.Void", "Foo.Bar"],- libBuildInfo = BuildInfo {- buildable = True,- ccOptions = ["-g", "-o"],- ldOptions = ["-BStatic", "-dn"],- frameworks = ["foo"],- cSources = ["not/even/rain.c", "such/small/hands"],- hsSourceDirs = ["src", "src2"],- otherModules = ["Distribution.Package",- "Distribution.Version",- "Distribution.Simple.GHCPackageConfig"],- extensions = [OverlappingInstances, TypeSynonymInstances],- extraLibs = ["libfoo", "bar", "bang"],- extraLibDirs = ["/usr/local/libs"],- includeDirs = ["your/slightest", "look/will"],- includes = ["/easily/unclose", "/me", "funky, path\\name"],- installIncludes = ["/easily/unclose", "/me", "funky, path\\name"],- ghcProfOptions = [],- options = [(GHC,["-fTH","-fglasgow-exts"])- ,(Hugs,["+TH"]),(NHC,[]),(JHC,[])]- }},-- executables = [Executable "somescript" - "SomeFile.hs" (emptyBuildInfo {- otherModules=["Foo1","Util","Main"],- hsSourceDirs = ["scripts"],- extensions = [OverlappingInstances],- options = [(GHC,[]),(Hugs,[]),(NHC,[]),(JHC,[])]- })]- }---- Parse an old style package description. Assumes no flags etc. being used.-compatParseDescription :: String -> ParseResult PackageDescription-compatParseDescription descr = do- gpd <- parsePackageDescription descr- case finalizePackageDescription [] Nothing "" "" ("",Version [] []) gpd of- Left _ -> syntaxError (-1) "finalize failed"- Right (pd,_) -> return pd--hunitTests :: [Test]-hunitTests = - [ TestLabel "license parsers" $ TestCase $- sequence_ [ assertParseOk ("license " ++ show lVal) lVal- (runP 1 "license" parseLicenseQ (show lVal))- | lVal <- [GPL,LGPL,BSD3,BSD4] ]-- , TestLabel "Required fields" $ TestCase $- do assertParseOk "some fields"- emptyPackageDescription {- package = (PackageIdentifier "foo"- (Version [0,0] ["asdf"])) }- (compatParseDescription "Name: foo\nVersion: 0.0-asdf")-- assertParseOk "more fields foo"- emptyPackageDescription {- package = (PackageIdentifier "foo"- (Version [0,0] ["asdf"])),- license = GPL }- (compatParseDescription "Name: foo\nVersion:0.0-asdf\nLicense: GPL")-- assertParseOk "required fields for foo"- emptyPackageDescription { - package = (PackageIdentifier "foo"- (Version [0,0] ["asdf"])),- license = GPL, copyright="2004 isaac jones" }- (compatParseDescription $ "Name: foo\nVersion:0.0-asdf\n" - ++ "Copyright: 2004 isaac jones\nLicense: GPL")- - , TestCase $ assertParseOk "no library" Nothing- (library `liftM` (compatParseDescription $ - "Name: foo\nVersion: 1\nLicense: GPL\n" ++- "Maintainer: someone\n\nExecutable: script\n" ++ - "Main-is: SomeFile.hs\n"))-- , TestCase $ assertParseOk "translate deprecated fields"- emptyPackageDescription {- extraSrcFiles = ["foo.c", "bar.ml"],- library = Just $ emptyLibrary {- libBuildInfo = emptyBuildInfo { hsSourceDirs = ["foo","bar"] }}}- (compatParseDescription $ - "hs-source-dir: foo bar\nother-files: foo.c bar.ml")-- , TestLabel "Package description" $ TestCase $ - assertParseOk "entire package description" - compatTestPkgDescAnswer- (compatParseDescription compatTestPkgDesc)- , TestLabel "Package description pretty" $ TestCase $ - case compatParseDescription compatTestPkgDesc of- ParseFailed _ -> assertBool "can't parse description" False- ParseOk _ d -> - case compatParseDescription $ showPackageDescription d of- ParseFailed _ ->- assertBool "can't parse description after pretty print!" False- ParseOk _ d' -> - assertBool ("parse . show . parse not identity."- ++" Incorrect fields:\n"- ++ (unlines $ comparePackageDescriptions d d'))- (d == d')- , TestLabel "Sanity checker" $ TestCase $ do- (warns, ers) <- sanityCheckPackage emptyPackageDescription- assertEqual "Wrong number of errors" 2 (length ers)- assertEqual "Wrong number of warnings" 3 (length warns)- ]---- |Compare two package descriptions and see which fields aren't the same.-comparePackageDescriptions :: PackageDescription- -> PackageDescription- -> [String] -- ^Errors-comparePackageDescriptions p1 p2- = catMaybes $ myCmp package "package" - : myCmp license "license"- : myCmp licenseFile "licenseFile"- : myCmp copyright "copyright"- : myCmp maintainer "maintainer"- : myCmp author "author"- : myCmp stability "stability"- : myCmp testedWith "testedWith"- : myCmp homepage "homepage"- : myCmp pkgUrl "pkgUrl"- : myCmp synopsis "synopsis"- : myCmp description "description"- : myCmp category "category"- : myCmp buildDepends "buildDepends"- : myCmp library "library"- : myCmp executables "executables"- : myCmp descCabalVersion "cabal-version" - : myCmp buildType "build-type" : []- where canon_p1 = canonOptions p1- canon_p2 = canonOptions p2- - myCmp :: (Eq a, Show a) => (PackageDescription -> a)- -> String -- Error message- -> Maybe String -- - myCmp f er = let e1 = f canon_p1- e2 = f canon_p2- in toMaybe (e1 /= e2)- (er ++ " Expected: " ++ show e1- ++ " Got: " ++ show e2)--canonOptions :: PackageDescription -> PackageDescription-canonOptions pd =- pd{ library = fmap canonLib (library pd),- executables = map canonExe (executables pd) }- where- canonLib l = l { libBuildInfo = canonBI (libBuildInfo l) }- canonExe e = e { buildInfo = canonBI (buildInfo e) }-- canonBI bi = bi { options = canonOptions (options bi) }-- canonOptions opts = sortBy (comparing fst) opts-- comparing f a b = f a `compare` f b---- |Assert that the 2nd value parses correctly and matches the first value-assertParseOk :: (Eq val) => String -> val -> ParseResult val -> Assertion-assertParseOk mes expected actual- = assertBool mes- (case actual of- ParseOk _ v -> v == expected- _ -> False)--test :: IO Counts-test = runTestTT (TestList hunitTests)---------------------------------------------------------------------------------test_stanzas' = parsePackageDescription testFile--- ParseOk _ x -> putStrLn $ show x--- _ -> return ()--testFile = unlines $- [ "Name: dwim"- , "Cabal-version: >= 1.7"- , ""- , "Description: This is a test file "- , " with a description longer than two lines. "- , ""- , "flag Debug {"- , " Description: Enable debug information"- , " Default: False" - , "}"- , "flag build_wibble {"- , "}"- , ""- , "library {"- , " build-depends: blub"- , " exposed-modules: DWIM.Main, DWIM"- , " if os(win32) && flag(debug) {"- , " build-depends: hunit"- , " ghc-options: -DDEBUG"- , " exposed-modules: DWIM.Internal"- , " if !flag(debug) {"- , " build-depends: impossible"- , " }"- , " }"- , "}" - , ""- , "executable foo-bar {"- , " Main-is: Foo.hs"- , " Build-depends: blab"- , "}"- , "executable wobble {"- , " Main-is: Wobble.hs"- , " if flag(debug) {"- , " Build-depends: hunit"- , " }"- , "}"- , "executable wibble {"- , " Main-is: Wibble.hs"- , " hs-source-dirs: wib-stuff"- , " if flag(build_wibble) {"- , " Build-depends: wiblib >= 0.42"- , " } else {"- , " buildable: False"- , " }"- , "}"- ]--{--test_compatParsing = - let ParseOk ws (p, pold) = do - fs <- readFields testPkgDesc - ppd <- parsePackageDescription' fs- let Right (pd,_) = finalizePackageDescription [] (Just pkgs) os arch ppd- pdold <- parsePackageDescription testPkgDesc- return (pd, pdold)- in do putStrLn $ unlines $ map show ws- putStrLn "==========="- putStrLn $ showPackageDescription p- putStrLn "==========="- putStrLn $ showPackageDescription testPkgDescAnswer- putStrLn "==========="- putStrLn $ showPackageDescription pold- putStrLn $ show (p == pold)- where- pkgs = [ PackageIdentifier "haskell-src" (Version [1,0] []) - , PackageIdentifier "HUnit" (Version [1,1] ["rain"]) - ]- os = (MkOSName "win32")- arch = (MkArchName "amd64")--}-test_finalizePD =- case parsePackageDescription testFile of- ParseFailed err -> print err- ParseOk _ ppd -> do- case finalizePackageDescription [("debug",True)] (Just pkgs) os arch impl ppd of- Right (pd,fs) -> do putStrLn $ showPackageDescription pd- print fs- Left missing -> putStrLn $ "missing: " ++ show missing- putStrLn $ showPackageDescription $ - flattenPackageDescription ppd- where- pkgs = [ PackageIdentifier "blub" (Version [1,0] []) - --, PackageIdentifier "hunit" (Version [1,1] []) - , PackageIdentifier "blab" (Version [0,1] []) - ]- os = "win32"- arch = "amd64"- impl = ("ghc", Version [6,6] [])---#endif-+-----------------------------------------------------------------------------+-- |+-- 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+ ( currentDir, 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 { hsSourceDirs = [currentDir] }++-- | 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."
+ Distribution/PackageDescription/Check.hs view
@@ -0,0 +1,616 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.PackageDescription.Check+-- Copyright : Lennart Kolmodin 2008+--+-- Maintainer : Lennart Kolmodin <kolmodin@gentoo.org>+-- Stability : alpha+-- Portability : portable+--+-- This module provides functionality to check for common mistakes.++{- 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.Check (+ -- * Package Checking+ PackageCheck(..),+ checkPackage,+ checkConfiguredPackage,+ checkPackageFiles+ ) where++import Data.Maybe (isNothing, catMaybes, fromMaybe)+import Data.List (sort, group, isPrefixOf)+import Control.Monad (filterM)+import System.Directory (doesFileExist, doesDirectoryExist)++import Distribution.PackageDescription hiding (freeVars)+import Distribution.PackageDescription.Configuration+ ( flattenPackageDescription )+import Distribution.Compiler+ ( CompilerFlavor(..) )+import Distribution.System+ ( OS(..), Arch(..) )+import Distribution.License+ ( License(..) )+import Distribution.Simple.Utils+ ( cabalVersion, intercalate )++import Distribution.Version+ ( Version(..), withinRange )+import Distribution.Package+ ( packageName, packageVersion )+import Distribution.Text+ ( display, simpleParse )+import Language.Haskell.Extension (Extension(..))+import System.FilePath (takeExtension, isRelative, splitDirectories, (</>))++-- | Results of some kind of failed package check.+--+-- There are a range of severities, from merely dubious to totally insane.+-- All of them come with a human readable explanation. In future we may augment+-- them with more machine readable explanations, for example to help an IDE+-- suggest automatic corrections.+--+data PackageCheck =++ -- | This package description is no good. There's no way it's going to+ -- build sensibly. This should give an error at configure time.+ PackageBuildImpossible { explanation :: String }++ -- | A problem that is likely to affect building the package, or an+ -- issue that we'd like every package author to be aware of, even if+ -- the package is never distributed.+ | PackageBuildWarning { explanation :: String }++ -- | An issue that might not be a problem for the package author but+ -- might be annoying or determental when the package is distributed to+ -- users. We should encourage distributed packages to be free from these+ -- issues, but occasionally there are justifiable reasons so we cannot+ -- ban them entirely.+ | PackageDistSuspicious { explanation :: String }++ -- | An issue that is ok in the author's environment but is almost+ -- certain to be a portability problem for other environments. We can+ -- quite legitimately refuse to publicly distribute packages with these+ -- problems.+ | PackageDistInexcusable { explanation :: String }++instance Show PackageCheck where+ show notice = explanation notice++check :: Bool -> PackageCheck -> Maybe PackageCheck+check False _ = Nothing+check True pc = Just pc++-- ------------------------------------------------------------+-- * Standard checks+-- ------------------------------------------------------------++-- TODO:+--+-- * check for unknown 'OS's and 'Arch's. This requires checking the+-- 'GenericPackageDescription' which we do not currently get passed.++-- | Check for common mistakes and problems in package descriptions.+--+-- This is the standard collection of checks covering all apsects except+-- for checks that require looking at files within the package. For those+-- see 'checkPackageFiles'.+--+-- It requires the 'GenericPackageDescription' and optionally a particular+-- configuration of that package. If you pass 'Nothing' then we just check+-- a version of the generic description using 'flattenPackageDescription'.+--+checkPackage :: GenericPackageDescription+ -> Maybe PackageDescription+ -> [PackageCheck]+checkPackage gpkg mpkg =+ checkConfiguredPackage pkg+ ++ checkConditionals gpkg+ where+ pkg = fromMaybe (flattenPackageDescription gpkg) mpkg++--TODO: make this variant go away+-- we should alwaws know the GenericPackageDescription+checkConfiguredPackage :: PackageDescription -> [PackageCheck]+checkConfiguredPackage pkg =+ checkSanity pkg+ ++ checkFields pkg+ ++ checkLicense pkg+ ++ checkGhcOptions pkg+ ++ checkCCOptions pkg+ ++ checkPaths pkg+++-- ------------------------------------------------------------+-- * Basic sanity checks+-- ------------------------------------------------------------++-- | Check that this package description is sane.+--+checkSanity :: PackageDescription -> [PackageCheck]+checkSanity pkg =+ catMaybes [++ check (null . packageName $ pkg) $+ PackageBuildImpossible "No 'name' field."++ , check (null . versionBranch . packageVersion $ pkg) $+ PackageBuildImpossible "No 'version' field."++ , check (null (executables pkg) && isNothing (library pkg)) $+ PackageBuildImpossible+ "No executables and no library found. Nothing to do."+ ]++ ++ maybe [] checkLibrary (library pkg)+ ++ concatMap checkExecutable (executables pkg)++ ++ catMaybes [++ check (not $ cabalVersion `withinRange` requiredCabalVersion) $+ PackageBuildImpossible $+ "This package requires Cabal version: "+ ++ display requiredCabalVersion+ ]++ where requiredCabalVersion = descCabalVersion pkg++checkLibrary :: Library -> [PackageCheck]+checkLibrary lib =+ catMaybes [++ check (not (null moduleDuplicates)) $+ PackageBuildWarning $+ "Duplicate modules in library: " ++ commaSep moduleDuplicates+ ]++ where moduleDuplicates = [ module_+ | let modules = exposedModules lib+ ++ otherModules (libBuildInfo lib)+ , (module_:_:_) <- group (sort modules) ]++checkExecutable :: Executable -> [PackageCheck]+checkExecutable exe =+ catMaybes [++ check (null (modulePath exe)) $+ PackageBuildImpossible $+ "No 'Main-Is' field found for executable " ++ exeName exe++ , check (not (null (modulePath exe))+ && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $+ PackageBuildImpossible $+ "The 'Main-Is' field must specify a '.hs' or '.lhs' file "+ ++ "(even if it is generated by a preprocessor)."++ , check (not (null moduleDuplicates)) $+ PackageBuildWarning $+ "Duplicate modules in executable '" ++ exeName exe ++ "': "+ ++ commaSep moduleDuplicates+ ]++ where moduleDuplicates = [ module_+ | let modules = otherModules (buildInfo exe)+ , (module_:_:_) <- group (sort modules) ]++-- ------------------------------------------------------------+-- * Additional pure checks+-- ------------------------------------------------------------++checkFields :: PackageDescription -> [PackageCheck]+checkFields pkg =+ catMaybes [++ 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'."++ , case buildType pkg of+ Just (UnknownBuildType unknown) -> Just $+ PackageBuildWarning $+ quote unknown ++ " is not a known 'build-type'. "+ ++ "The known build types are: "+ ++ intercalate ", " (map display knownBuildTypes)+ _ -> Nothing++ , check (not (null unknownCompilers)) $+ PackageBuildWarning $+ "Unknown compiler " ++ intercalate ", " (map quote unknownCompilers)+ ++ " in 'tested-with' field."++ , check (not (null unknownExtensions)) $+ PackageBuildWarning $+ "Unknown extensions: " ++ intercalate ", " unknownExtensions++ , check (null (category pkg)) $+ PackageDistSuspicious "No 'category' field."++ , check (null (description pkg)) $+ PackageDistSuspicious "No 'description' field."++ , check (null (maintainer pkg)) $+ PackageDistSuspicious "No 'maintainer' field."++ , check (null (synopsis pkg)) $+ PackageDistSuspicious "No 'synopsis' field."++ , check (length (synopsis pkg) >= 80) $+ PackageDistSuspicious+ "The 'synopsis' field is rather long (max 80 chars is recommended)."+ ]+ where+ unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ]+ unknownExtensions = [ name | bi <- allBuildInfo pkg+ , UnknownExtension name <- extensions bi ]++checkLicense :: PackageDescription -> [PackageCheck]+checkLicense pkg =+ catMaybes [++ check (license pkg == AllRightsReserved) $+ PackageDistInexcusable+ "The 'license' field is missing or specified as AllRightsReserved."++ , case license pkg of+ UnknownLicense l -> Just $+ PackageBuildWarning $+ quote ("license: " ++ l) ++ " is not a recognised license."+ _ -> Nothing++ , check (license pkg == BSD4) $+ PackageDistSuspicious $+ "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "+ ++ "refers to the old 4-clause BSD license with the advertising "+ ++ "clause. 'BSD3' refers the new 3-clause BSD license."++ , check (license pkg `notElem` [AllRightsReserved, PublicDomain]+ -- AllRightsReserved and PublicDomain are not strictly+ -- licenses so don't need license files.+ && null (licenseFile pkg)) $+ PackageDistSuspicious "A 'license-file' is not specified."+ ]++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."++ , check (not has_WerrorWall && has_Werror) $+ PackageDistSuspicious $+ "'ghc-options: -Werror' makes the package easy to "+ ++ "break with future GHC versions."++ , checkFlags ["-fasm"] $+ PackageDistInexcusable $+ "'ghc-options: -fasm' is unnecessary and breaks on all "+ ++ "arches except for x86, x86-64 and ppc."++ , checkFlags ["-fvia-C"] $+ PackageDistSuspicious $+ "'ghc-options: -fvia-C' is usually unnecessary."++ , checkFlags ["-fhpc"] $+ PackageDistInexcusable $+ "'ghc-options: -fhpc' is not appropriate for a distributed package."++ , check (any ("-d" `isPrefixOf`) all_ghc_options) $+ PackageDistInexcusable $+ "'ghc-options: -d*' debug flags are not appropriate for a distributed package."++ , checkFlags ["-prof"] $+ PackageDistInexcusable $+ "'ghc-options: -prof' is not needed. Use the --enable-library-profiling configure flag."++ , checkFlags ["-o"] $+ PackageDistInexcusable $+ "'ghc-options: -o' is not allowed. The output files are named automatically."++ , checkFlags ["-hide-package"] $+ PackageDistInexcusable $+ "'ghc-options: -hide-package' is never needed. Cabal hides all packages."++ , checkFlags ["-main-is"] $+ PackageDistSuspicious $+ "'ghc-options: -main-is' is not portable."++ , checkFlags ["-O0", "-Onot"] $+ PackageDistInexcusable $+ "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."++ , checkFlags [ "-O", "-O1"] $+ PackageDistInexcusable $+ "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. "+ ++ "Setting it yourself interferes with the --disable-optimization flag."++ , checkFlags ["-O2"] $+ PackageDistSuspicious $+ "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit "+ ++ "and not just imposing longer compile times on your users."++ , checkFlags ["-split-objs"] $+ PackageDistInexcusable $+ "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."++ , checkFlags ["-optl-Wl,-s"] $+ PackageDistSuspicious $+ "'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"+ ++ " which is necessary when building packages for some Linux"+ ++ " distributions and using '-optl-Wl,-s' prevents that from working."++ , checkFlags ["-fglasgow-exts"] $+ PackageDistSuspicious $+ "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."++ , checkAlternatives "ghc-options" "extensions"+ [ (flag, display extension) | flag <- all_ghc_options+ , Just extension <- [ghcExtension flag] ]++ , checkAlternatives "ghc-options" "extensions"+ [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options+ , case simpleParse extension of+ Just (UnknownExtension _) -> True+ Just ext -> ext `elem` compatExtensions+ || not (Version [1,1,6] []+ `withinRange` descCabalVersion pkg)+ Nothing -> False ]++ , checkAlternatives "ghc-options" "cpp-options" $+ [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]+ ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]++ , checkAlternatives "ghc-options" "include-dirs"+ [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]++ , checkAlternatives "ghc-options" "extra-libraries"+ [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]++ , checkAlternatives "ghc-options" "extra-lib-dirs"+ [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]+ ]++ where+ has_WerrorWall = flip any ghc_options $ \opts ->+ "-Werror" `elem` opts+ && ("-Wall" `elem` opts || "-W" `elem` opts)+ has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options++ ghc_options = [ strs | bi <- allBuildInfo pkg+ , (GHC, strs) <- options bi ]+ all_ghc_options = concat ghc_options++ checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck+ checkFlags flags = check (any (`elem` flags) all_ghc_options)++ ghcExtension ('-':'f':name) = case name of+ "allow-overlapping-instances" -> Just OverlappingInstances+ "th" -> Just TemplateHaskell+ "ffi" -> Just ForeignFunctionInterface+ "fi" -> Just ForeignFunctionInterface+ "no-monomorphism-restriction" -> Just NoMonomorphismRestriction+ "no-mono-pat-binds" -> Just NoMonoPatBinds+ "allow-undecidable-instances" -> Just UndecidableInstances+ "allow-incoherent-instances" -> Just IncoherentInstances+ "arrows" -> Just Arrows+ "generics" -> Just Generics+ "no-implicit-prelude" -> Just NoImplicitPrelude+ "implicit-params" -> Just ImplicitParams+ "bang-patterns" -> Just BangPatterns+ "scoped-type-variables" -> Just ScopedTypeVariables+ "extended-default-rules" -> Just ExtendedDefaultRules+ _ -> Nothing+ ghcExtension ('-':'c':"pp") = Just CPP+ ghcExtension _ = Nothing++ -- the known extensions in Cabal-1.1.6 that came with ghc-6.6:+ -- we can drop this test when Cabal-1.4+ is widely deployed because+ -- from that point on we can add new extensions without worrying about+ -- breaking old versions of cabal.+ compatExtensions =+ [ OverlappingInstances, UndecidableInstances, IncoherentInstances+ , RecursiveDo, ParallelListComp, MultiParamTypeClasses+ , NoMonomorphismRestriction, FunctionalDependencies, Rank2Types+ , RankNTypes, PolymorphicComponents, ExistentialQuantification+ , ScopedTypeVariables, ImplicitParams, FlexibleContexts+ , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns+ , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface+ , Arrows, Generics, NoImplicitPrelude, NamedFieldPuns, PatternGuards+ , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms+ , HereDocuments+ ]++checkCCOptions :: PackageDescription -> [PackageCheck]+checkCCOptions pkg =+ catMaybes [++ checkAlternatives "cc-options" "include-dirs"+ [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ]++ , checkAlternatives "cc-options" "extra-libraries"+ [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ]++ , checkAlternatives "cc-options" "extra-lib-dirs"+ [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ]++ , checkAlternatives "ld-options" "extra-libraries"+ [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]++ , checkAlternatives "ld-options" "extra-lib-dirs"+ [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]+ ]++ where all_ccOptions = [ opts | bi <- allBuildInfo pkg+ , opts <- ccOptions bi ]+ all_ldOptions = [ opts | bi <- allBuildInfo pkg+ , opts <- ldOptions bi ]++checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck+checkAlternatives badField goodField flags =+ check (not (null badFlags)) $+ PackageBuildWarning $+ "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)+ ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)++ where (badFlags, goodFlags) = unzip flags++checkPaths :: PackageDescription -> [PackageCheck]+checkPaths pkg =+ [ PackageBuildWarning {+ explanation = quote (kind ++ ": " ++ dir)+ ++ " is a relative path outside of the source tree. "+ ++ "This will not work when generating a tarball with 'sdist'."+ }+ | bi <- allBuildInfo pkg+ , (dir, kind) <- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]+ ++ [ (dir, "include-dirs") | dir <- includeDirs bi ]+ ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]+ , isOutsideTree dir ]+ where isOutsideTree dir = case splitDirectories dir of+ "..":_ -> True+ _ -> False++-- ------------------------------------------------------------+-- * Checks on the GenericPackageDescription+-- ------------------------------------------------------------++checkConditionals :: GenericPackageDescription -> [PackageCheck]+checkConditionals pkg =+ catMaybes [++ check (not $ null unknownOSs) $+ PackageDistInexcusable $+ "Unknown operating system name "+ ++ intercalate ", " (map quote unknownOSs)++ , check (not $ null unknownArches) $+ PackageDistInexcusable $+ "Unknown architecture name "+ ++ intercalate ", " (map quote unknownArches)++ , check (not $ null unknownImpls) $+ PackageDistInexcusable $+ "Unknown compiler name "+ ++ intercalate ", " (map quote unknownImpls)+ ]+ where+ unknownOSs = [ os | OS (OtherOS os) <- conditions ]+ unknownArches = [ arch | Arch (OtherArch arch) <- conditions ]+ unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ]+ conditions = maybe [] freeVars (condLibrary pkg)+ ++ concatMap (freeVars . snd) (condExecutables pkg)+ 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 c1 -> condfv c1+ COr c1 c2 -> condfv c1 ++ condfv c2+ CAnd c1 c2 -> condfv c1 ++ condfv c2++-- ------------------------------------------------------------+-- * Checks in IO+-- ------------------------------------------------------------++-- | 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++ return $ catMaybes [licenseError, setupError, configureError]+ ++ localPathErrors++checkLicenseExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck)+checkLicenseExists pkg root+ | null (licenseFile pkg) = return Nothing+ | otherwise = do+ exists <- doesFileExist (root </> file)+ return $ check (not exists) $+ PackageBuildWarning $+ "The 'license-file' field refers to the file " ++ quote file+ ++ " which does not exist."++ where+ file = licenseFile pkg++checkSetupExists :: PackageDescription -> FilePath -> IO (Maybe PackageCheck)+checkSetupExists _ root = do+ hsexists <- doesFileExist (root </> "Setup.hs")+ lhsexists <- doesFileExist (root </> "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")+ 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+ let dirs = [ (dir, kind)+ | bi <- allBuildInfo pkg+ , (dir, kind) <-+ [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]+ ++ [ (dir, "include-dirs") | dir <- includeDirs bi ]+ ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]+ , isRelative dir ]+ missing <- filterM (fmap not . doesDirectoryExist . (root </>) . fst) dirs+ return [ PackageBuildWarning {+ explanation = quote (kind ++ ": " ++ dir)+ ++ " directory does not exist."+ }+ | (dir, kind) <- missing ]++-- ------------------------------------------------------------+-- * Utils+-- ------------------------------------------------------------++quote :: String -> String+quote s = "'" ++ s ++ "'"++commaSep :: [String] -> String+commaSep = intercalate ","
+ Distribution/PackageDescription/Configuration.hs view
@@ -0,0 +1,503 @@+{-# 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.Configuration+-- Copyright : Thomas Schilling, 2007+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Configurations++{- 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.Configuration (+ finalizePackageDescription,+ flattenPackageDescription,+ ) where++import Distribution.Package (Package, Dependency(..))+import Distribution.PackageDescription+ ( GenericPackageDescription(..), PackageDescription(..)+ , Library(..), Executable(..), BuildInfo(..)+ , Flag(..), FlagName(..), FlagAssignment+ , CondTree(..), ConfVar(..), Condition(..) )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Version+ ( VersionRange(..), withinRange )+import Distribution.Compiler+ ( CompilerId(CompilerId) )+import Distribution.System+ ( OS, Arch )+import Distribution.Simple.Utils (currentDir)++import Data.Maybe ( catMaybes, maybeToList )+import Data.List ( nub )+import Data.Map ( Map, fromListWith, toList )+import qualified Data.Map as M+import Data.Monoid++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)+import qualified Text.Read as R+import qualified Text.Read.Lex as L+#endif++------------------------------------------------------------------------------++-- | Simplify the condition and return its free variables.+simplifyCondition :: Condition c+ -> (c -> Either d Bool) -- ^ (partial) variable assignment+ -> (Condition d, [d])+simplifyCondition cond i = fv . walk $ cond+ where+ walk cnd = case cnd of+ Var v -> either Var Lit (i v)+ Lit b -> Lit b+ CNot c -> case walk c of+ Lit True -> Lit False+ Lit False -> Lit True+ c' -> CNot c'+ COr c d -> case (walk c, walk d) of+ (Lit False, d') -> d'+ (Lit True, _) -> Lit True+ (c', Lit False) -> c'+ (_, Lit True) -> Lit True+ (c',d') -> COr c' d'+ CAnd c d -> case (walk c, walk d) of+ (Lit False, _) -> Lit False+ (Lit True, d') -> d'+ (_, Lit False) -> Lit False+ (c', Lit True) -> c'+ (c',d') -> CAnd c' d'+ -- gather free vars+ fv c = (c, fv' c)+ fv' c = case c of+ Var v -> [v]+ Lit _ -> []+ CNot c' -> fv' c'+ COr c1 c2 -> fv' c1 ++ fv' c2+ CAnd c1 c2 -> fv' c1 ++ fv' c2++-- | Simplify a configuration condition using the os and arch names. Returns+-- the names of all the flags occurring in the condition.+simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar+ -> (Condition FlagName, [FlagName])+simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags)+ where+ (cond', flags) = simplifyCondition cond interp+ interp (OS os') = Right $ os' == os+ interp (Arch arch') = Right $ arch' == arch+ interp (Impl comp' vr) = Right $ comp' == comp+ && compVer `withinRange` vr+ interp (Flag f) = Left f++-- XXX: Add instances and check+--+-- prop_sC_idempotent cond a o = cond' == cond''+-- where+-- cond' = simplifyCondition cond a o+-- cond'' = simplifyCondition cond' a o+--+-- prop_sC_noLits cond a o = isLit res || not (hasLits res)+-- where+-- res = simplifyCondition cond a o+-- hasLits (Lit _) = True+-- hasLits (CNot c) = hasLits c+-- hasLits (COr l r) = hasLits l || hasLits r+-- hasLits (CAnd l r) = hasLits l || hasLits r+-- hasLits _ = False+--++------------------------------------------------------------------------------++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)+ where+ g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,+ fmap (mapCondTree fa fc fcnd) me)++mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a+mapTreeConstrs f = mapCondTree id f id++mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a+mapTreeConds f = mapCondTree id id f++mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b+mapTreeData f = mapCondTree f id id++-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for+-- clarity.+data DepTestRslt d = DepOk | MissingDeps d ++instance Monoid d => Monoid (DepTestRslt d) where+ mempty = DepOk+ mappend DepOk x = x+ mappend x DepOk = x+ mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')+++data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree+++-- | Try to find a flag assignment that satisfies the constaints of all trees.+--+-- Returns either the missing dependencies, or a tuple containing the+-- resulting data, the associated dependencies, and the chosen flag+-- assignments.+--+-- In case of failure, the _smallest_ number of of missing dependencies is+-- returned. [XXX: Could also be specified with a function argument.]+--+-- XXX: The current algorithm is rather naive. A better approach would be to:+--+-- * Rule out possible paths, by taking a look at the associated dependencies.+--+-- * Infer the required values for the conditions of these paths, and+-- calculate the required domains for the variables used in these+-- conditions. Then picking a flag assignment would be linear (I guess).+--+-- 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.+ -> OS -- ^ OS as returned by Distribution.System.buildOS+ -> Arch -- ^ Arch as returned by Distribution.System.buildArch+ -> CompilerId -- ^ Compiler flavour + version+ -> [Dependency] -- ^ Additional constraints+ -> [CondTree ConfVar [Dependency] a] + -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.+ -> Either [Dependency] -- missing dependencies+ ([a], [Dependency], FlagAssignment)+ -- ^ In the returned dependencies, there will be no duplicates by name+resolveWithFlags dom os arch impl constrs trees checkDeps =+ case try dom [] of+ Right r -> Right r+ Left dbt -> Left $ findShortest dbt+ where + extraConstrs = toDepMap constrs+ + -- simplify trees by (partially) evaluating all conditions and converting+ -- dependencies to dependency maps.+ simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps+ . mapTreeConds (fst . simplifyWithSysParams os arch impl))+ trees++ -- version to combine dependencies where the result will only contain keys+ -- from the left (first) map. If a key also exists in the right map, both+ -- constraints will be intersected.+ leftJoin :: DependencyMap -> DependencyMap -> DependencyMap+ leftJoin left extra =+ DependencyMap $+ M.foldWithKey tightenConstraint (unDependencyMap left)+ (unDependencyMap extra)+ where tightenConstraint n c l =+ case M.lookup n l of+ Nothing -> l+ Just vr -> M.insert n (IntersectVersionRanges vr c) l++ -- @try@ recursively tries all possible flag assignments in the domain and+ -- 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)) + $ 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 = + tryAll $ map (\v -> try rest ((n, v):flags)) vals++ tryAll = foldr mp mz++ -- special version of `mplus' for our local purposes+ mp (Left xs) (Left ys) = (Left (BTB xs ys))+ mp (Left _) m@(Right _) = m+ mp m@(Right _) _ = m++ -- `mzero'+ mz = Left (BTN [])++ env flags flag = (maybe (Left flag) Right . lookup flag) flags++ -- 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) = + let l = findShortest lt+ r = findShortest rt+ in case (l,r) of+ ([], xs) -> xs -- [] is too short+ (xs, []) -> xs+ ([x], _) -> [x] -- single elem is optimum+ (_, [x]) -> [x]+ (xs, ys) -> if lazyLengthCmp xs ys+ then xs else ys + -- lazy variant of @\xs ys -> length xs <= length ys@+ lazyLengthCmp [] _ = True+ lazyLengthCmp _ [] = False+ lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys++-- | 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 }+#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)+ deriving (Show, Read)+#else+-- The Show/Read instance for Data.Map in ghc-6.4 is useless+-- so we have to re-implement it here:+instance Show DependencyMap where+ showsPrec d (DependencyMap m) =+ showParen (d > 10) (showString "DependencyMap" . shows (M.toList m))++instance Read DependencyMap where+ readPrec = parens $ R.prec 10 $ do+ R.Ident "DependencyMap" <- R.lexP+ xs <- R.readPrec+ return (DependencyMap (M.fromList xs))+ where parens :: R.ReadPrec a -> R.ReadPrec a+ parens p = optional+ where+ optional = p R.+++ mandatory+ mandatory = paren optional++ paren :: R.ReadPrec a -> R.ReadPrec a+ paren p = do L.Punc "(" <- R.lexP+ x <- R.reset p+ L.Punc ")" <- R.lexP+ return x++ readListPrec = R.readListPrecDefault+#endif++instance Monoid DependencyMap where+ mempty = DependencyMap M.empty+ (DependencyMap a) `mappend` (DependencyMap b) = + DependencyMap (M.unionWith IntersectVersionRanges a b)++toDepMap :: [Dependency] -> DependencyMap+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 + -> (d, a)+simplifyCondTree env (CondNode a d ifs) =+ foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs+ where+ 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" ++-- | 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 + : maybeToList (fmap ignoreConditions me)++------------------------------------------------------------------------------+-- Convert GenericPackageDescription to PackageDescription+--++data PDTagged = Lib Library | Exe String Executable | PDNull deriving Show++instance Monoid PDTagged where+ mempty = PDNull+ PDNull `mappend` x = x+ x `mappend` PDNull = x+ Lib l `mappend` Lib l' = Lib (l `mappend` l')+ Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')+ _ `mappend` _ = bug "Cannot combine incompatible tags"++-- | Create a package description with all configurations resolved.+--+-- This function takes a `GenericPackageDescription` and several environment+-- parameters and tries to generate `PackageDescription` by finding a flag+-- assignment that result in satisfiable dependencies.+--+-- It takes as inputs a not necessarily complete specifications of flags+-- assignments, an optional package index as well as platform parameters. If+-- some flags are not assigned explicitly, this function will try to pick an+-- assignment that causes this function to succeed. The package index is+-- optional since on some platforms we cannot determine which packages have+-- been installed before. When no package index is supplied, every dependency+-- is assumed to be satisfiable, therefore all not explicitly assigned flags+-- will get their default values.+--+-- This function will fail if it cannot find a flag assignment that leads to+-- satisfiable dependencies. (It will not try alternative assignments for+-- 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+ -> Maybe (PackageIndex pkg) -- ^ Available dependencies. Pass 'Nothing' if+ -- this is unknown.+ -> OS -- ^ OS-name+ -> Arch -- ^ Arch-name+ -> CompilerId -- ^ Compiler + Version+ -> [Dependency] -- ^ Additional constraints+ -> GenericPackageDescription+ -> Either [Dependency]+ (PackageDescription, FlagAssignment)+ -- ^ 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+ Right ((mlib, exes'), deps, flagVals) ->+ Right ( pkg { library = mlib+ , executables = exes'+ , buildDepends = nub deps+ }+ , flagVals )+ Left missing -> Left $ nub missing+ where+ -- Combine lib and exes into one list of @CondTree@s with tagged data+ condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )+ ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0++ untagRslts = foldr untag (Nothing, [])+ where+ untag (Lib _) (Just _, _) = bug "Only one library expected"+ untag (Lib l) (Nothing, exes) = (Just l, exes)+ untag (Exe n e) (mlib, exes)+ | any ((== n) . fst) exes = bug "Exe with same name found"+ | otherwise = (mlib, exes ++ [(n, e)])+ untag PDNull x = x -- actually this should not happen, but let's be liberal++ resolveFlags =+ case resolveWithFlags flagChoices os arch impl constraints condTrees check of+ Right (as, ds, fs) ->+ let (mlib, exes) = untagRslts as in+ Right ( (fmap libFillInDefaults mlib,+ map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes),+ 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+ --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices+ check ds = if all satisfyDep ds+ then DepOk+ else MissingDeps $ filter (not . satisfyDep) ds+ -- if we don't know which packages are present, we just accept any+ -- dependency+ satisfyDep = maybe (const True)+ (\pkgs -> not . null . PackageIndex.lookupDependency pkgs)+ mpkgs++{-+let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])+let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])++let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]+let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index+let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds+resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ...+resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ...+-}++-- | Flatten a generic package description by ignoring all conditions and just+-- join the field descriptors into on package description. Note, however,+-- that this may lead to inconsistent field values, since all values are+-- joined into one field, which may not be possible in the original package+-- description, due to the use of exclusive choices (if ... else ...).+--+-- XXX: One particularly tricky case is defaulting. In the original package+-- description, e.g., the source directory might either be the default or a+-- certain, explicitly set path. Since defaults are filled in only after the+-- package has been resolved and when no explicit value has been set, the+-- default path will be missing from the package description returned by this+-- function.+flattenPackageDescription :: GenericPackageDescription -> PackageDescription+flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0) =+ pkg { library = mlib+ , executables = reverse exes+ , buildDepends = nub $ ldeps ++ reverse edeps+ }+ where+ (mlib, ldeps) = case mlib0 of+ Just lib -> let (l,ds) = ignoreConditions lib in+ (Just (libFillInDefaults l), ds)+ Nothing -> (Nothing, [])+ (exes, edeps) = foldr flattenExe ([],[]) exes0+ flattenExe (n, t) (es, ds) =+ let (e, ds') = ignoreConditions t in+ ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )++-- This is in fact rather a hack. The original version just overrode the+-- default values, however, when adding conditions we had to switch to a+-- modifier-based approach. There, nothing is ever overwritten, but only+-- joined together.+--+-- This is the cleanest way i could think of, that doesn't require+-- changing all field parsing functions to return modifiers instead.+libFillInDefaults :: Library -> Library+libFillInDefaults lib@(Library { libBuildInfo = bi }) =+ lib { libBuildInfo = biFillInDefaults bi }++exeFillInDefaults :: Executable -> Executable+exeFillInDefaults exe@(Executable { buildInfo = bi }) =+ exe { buildInfo = biFillInDefaults bi }++biFillInDefaults :: BuildInfo -> BuildInfo+biFillInDefaults bi =+ if null (hsSourceDirs bi)+ then bi { hsSourceDirs = [currentDir] }+ else bi++bug :: String -> a+bug msg = error $ msg ++ ". Consider this a bug."
Distribution/ParseUtils.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ParseUtils@@ -45,38 +44,38 @@ -- #hide module Distribution.ParseUtils (- LineNo, PError(..), PWarning, locatedErrorMsg, syntaxError, warning,- runP, ParseResult(..), catchParseError, parseFail,- Field(..), fName, lineNo,- FieldDescr(..), readFields,+ LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,+ runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,+ Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, parseFilePathQ, parseTokenQ,- parseModuleNameQ, parseDependency, parsePkgconfigDependency,+ parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, parseOptVersion, parsePackageNameQ, parseVersionRangeQ, parseTestedWithQ, parseLicenseQ, parseExtensionQ, parseSepList, parseCommaList, parseOptCommaList,- showFilePath, showToken, showTestedWith, showDependency, showFreeText,+ showFilePath, showToken, showTestedWith, showFreeText, field, simpleField, listField, commaListField, optsField, liftField,- parseReadS, parseReadSQ, parseQuoted,+ boolField, parseQuoted,++ UnrecFieldParser, warnUnrec, ignoreUnrec, ) where -import Distribution.Compiler (CompilerFlavor)+import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) import Distribution.License import Distribution.Version-import Distribution.Package ( parsePackageName )+import Distribution.Package ( parsePackageName, Dependency(..) ) import Distribution.Compat.ReadP as ReadP hiding (get)+import Distribution.ReadE+import Distribution.Text+ ( Text(..) )+import Distribution.Simple.Utils (intercalate, lowercase) import Language.Haskell.Extension (Extension) import Text.PrettyPrint.HughesPJ hiding (braces)-import Data.Char (isSpace, isUpper, toLower, isAlphaNum)-import Data.Maybe ( fromMaybe)-import Data.List (intersperse)--#ifdef DEBUG-import Test.HUnit (Test(..), assertBool, Assertion, runTestTT, Counts, assertEqual)-import IO-import System.Environment ( getArgs )-import Control.Monad ( zipWithM_ )-#endif+import Data.Char (isSpace, isUpper, toLower, isAlphaNum, isDigit)+import Data.Maybe (fromMaybe)+import Data.Tree as Tree (Tree(..), flatten)+import System.FilePath (normalise) -- ----------------------------------------------------------------------------- @@ -88,8 +87,17 @@ | FromString String (Maybe LineNo) deriving Show -type PWarning = String+data PWarning = PWarning String+ | UTFWarning LineNo String+ deriving Show +showPWarning :: FilePath -> PWarning -> String+showPWarning fpath (PWarning msg) =+ normalise fpath ++ ": " ++ msg+showPWarning fpath (UTFWarning line fname) =+ normalise fpath ++ ":" ++ show line+ ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."+ data ParseResult a = ParseFailed PError | ParseOk [PWarning] a deriving Show @@ -112,14 +120,28 @@ runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a runP line fieldname p s = case [ x | (x,"") <- results ] of- [a] -> ParseOk [] a+ [a] -> ParseOk (utf8Warnings line fieldname s) a+ --TODO: what is this double parse thing all about?+ -- Can't we just do the all isSpace test the first time? [] -> case [ x | (x,ys) <- results, all isSpace ys ] of- [a] -> ParseOk [] a+ [a] -> ParseOk (utf8Warnings line fieldname s) a [] -> ParseFailed (NoParse fieldname line) _ -> ParseFailed (AmbigousParse fieldname line) _ -> ParseFailed (AmbigousParse fieldname line) where results = readP_to_S p s +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a+runE line fieldname p s =+ case runReadE p s of+ Right a -> ParseOk (utf8Warnings line fieldname s) a+ Left e -> syntaxError line ("Parse of field '"++fieldname++"' failed ("++e++"): " )++utf8Warnings :: LineNo -> String -> String -> [PWarning]+utf8Warnings line fieldname s =+ take 1 [ UTFWarning n fieldname+ | (n,l) <- zip [line..] (lines s)+ , '\xfffd' `elem` l ]+ locatedErrorMsg :: PError -> (Maybe LineNo, String) locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.")@@ -133,7 +155,7 @@ tabsError ln = ParseFailed $ TabsError ln warning :: String -> ParseResult ()-warning s = ParseOk [s] ()+warning s = ParseOk [PWarning s] () -- | Field descriptor. The parameter @a@ parameterizes over where the field's -- value is stored in.@@ -196,6 +218,51 @@ | f == f' = (f, opts' ++ opts) : rest | otherwise = (f',opts') : update f opts rest +-- TODO: this is a bit smelly hack. It's because we want to parse bool fields+-- liberally but not accept new parses. We cannot do that with ReadP+-- because it does not support warnings. We need a new parser framwork!+boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b+boolField name get set = liftField get set (FieldDescr name showF readF)+ where+ showF = text . show+ readF line str _+ | str == "True" = ParseOk [] True+ | str == "False" = ParseOk [] False+ | lstr == "true" = ParseOk [caseWarning] True+ | lstr == "false" = ParseOk [caseWarning] False+ | otherwise = ParseFailed (NoParse name line)+ where+ lstr = lowercase str+ 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++ppField :: String -> Doc -> Doc+ppField name fielddoc = text name <> colon <+> fielddoc+++-- | 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+-- (by returning Just x, where x is a possibly modified version+-- of the structure being built), or not (by returning Nothing).+type UnrecFieldParser a = (String,String) -> a -> Maybe a++-- | A default unrecognized field parser which simply returns Nothing,+-- i.e. ignores all unrecognized fields, so warnings will be generated.+warnUnrec :: UnrecFieldParser a+warnUnrec _ _ = Nothing++-- | A default unrecognized field parser which silently (i.e. no+-- warnings will be generated) ignores unrecognized fields, by+-- returning the structure being built unmodified.+ignoreUnrec :: UnrecFieldParser a+ignoreUnrec _ x = Just x+ ------------------------------------------------------------------------------ -- The data type for our three syntactic categories @@ -235,16 +302,12 @@ fName _ = error "fname: not a field or section" readFields :: String -> ParseResult [Field]-readFields input = - ifelse- =<< mapM (mkField 0)- =<< mkTree (tokenise input)+readFields input = ifelse+ =<< mapM (mkField 0)+ =<< mkTree tokens - where tokenise = concatMap tokeniseLine- . trimLines- . lines- . normaliseLineEndings- -- TODO: should decode UTF8+ where ls = (lines . normaliseLineEndings) input+ tokens = (concatMap tokeniseLine . trimLines) ls -- attach line number and determine indentation trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]@@ -409,7 +472,7 @@ mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l (name, rest) -> case trimLeading rest of- (':':rest') -> do let followingLines = concatMap flatten ts+ (':':rest') -> do let followingLines = concatMap Tree.flatten ts tabs = not (null [()| (_,True,_) <- followingLines ]) if tabs && d >= 1 then tabsError n@@ -422,7 +485,7 @@ followingLines' = map (\(_,_,s) -> stripDot s) followingLines allLines | null firstLine' = followingLines' | otherwise = firstLine' : followingLines'- in (concat . intersperse "\n") allLines+ in intercalate "\n" allLines stripDot "." = "" stripDot s = s @@ -467,16 +530,24 @@ -- removed until normalise is no longer broken, was: -- liftM normalise parseTokenQ -parseReadS :: Read a => ReadP r a-parseReadS = readS_to_P reads+parseBuildTool :: ReadP r Dependency+parseBuildTool = do name <- parseBuildToolNameQ+ skipSpaces+ ver <- parseVersionRangeQ <++ return AnyVersion+ skipSpaces+ return $ Dependency name ver -parseDependency :: ReadP r Dependency-parseDependency = do name <- parsePackageNameQ- skipSpaces- ver <- parseVersionRangeQ <++ return AnyVersion- skipSpaces- return $ Dependency name ver+parseBuildToolNameQ :: ReadP r String+parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName +-- like parsePackageName but accepts symbols in components+parseBuildToolName :: ReadP r String+parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')+ return (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, -- eg "gtk+-2.0" is a valid pkg-config package _name_. -- It then has a package version number like 2.10.13@@ -491,23 +562,23 @@ parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName parseVersionRangeQ :: ReadP r VersionRange-parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange+parseVersionRangeQ = parseQuoted parse <++ parse parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver- where ver = parseVersion <++ return noVersion+ where ver = parse <++ return noVersion noVersion = Version{ versionBranch=[], versionTags=[] } parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw- where tw = do compiler <- parseReadS+ where tw = do compiler <- parseCompilerFlavorCompat skipSpaces- version <- parseVersionRange <++ return AnyVersion+ version <- parse <++ return AnyVersion skipSpaces return (compiler,version) parseLicenseQ :: ReadP r License-parseLicenseQ = parseQuoted parseReadS <++ parseReadS+parseLicenseQ = parseQuoted parse <++ parse -- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a -- because the "compat" version of ReadP isn't quite powerful enough. In@@ -515,17 +586,16 @@ -- Hence the trick above to make 'lic' polymorphic. parseExtensionQ :: ReadP r Extension-parseExtensionQ = parseQuoted parseReadS <++ parseReadS+parseExtensionQ = parseQuoted parse <++ parse --- | Parse something optionally wrapped in quotes.-parseReadSQ :: Read a => ReadP r a-parseReadSQ = parseQuoted parseReadS <++ parseReadS+parseHaskellString :: ReadP r String+parseHaskellString = readS_to_P reads parseTokenQ :: ReadP r String-parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')+parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') parseTokenQ' :: ReadP r String-parseTokenQ' = parseReadS <++ munch1 (\x -> not (isSpace x))+parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) parseSepList :: ReadP r b -> ReadP r a -- ^The parser for the stuff between commas@@ -558,181 +628,9 @@ where dodgy c = isSpace c || c == ',' showTestedWith :: (CompilerFlavor,VersionRange) -> Doc-showTestedWith (compiler,version) = text (show compiler ++ " " ++ showVersionRange version)--showDependency :: Dependency -> Doc-showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)+showTestedWith (compiler, version) = text (show compiler) <+> disp version -- | Pretty-print free-format text, ensuring that it is vertically aligned, -- and with blank lines replaced by dots for correct re-parsing. showFreeText :: String -> Doc showFreeText s = vcat [text (if null l then "." else l) | l <- lines s]---- ----------------------------------------------- ** Tree bits---- Data.Tree was not present in ghc-6.2, and we only need these bits:--data Tree a = Node a (Forest a)-type Forest a = [Tree a]--flatten :: Tree a -> [a]-flatten t = squish t []- where squish (Node x ts) xs = x:foldr squish xs ts----------------------------------------------------------------------------------- TESTING--#ifdef DEBUG-test_readFields = case - readFields testFile - of- ParseOk _ x -> x == expectedResult- _ -> False- where - testFile = unlines $- [ "Cabal-version: 3"- , ""- , "Description: This is a test file "- , " with a description longer than two lines. "- , "if os(windows) {"- , " License: You may not use this software"- , " ."- , " If you do use this software you will be seeked and destroyed."- , "}"- , "if os(linux) {"- , " Main-is: foo1 "- , "}"- , ""- , "if os(vista) {"- , " executable RootKit {"- , " Main-is: DRMManager.hs"- , " }"- , "} else {"- , " executable VistaRemoteAccess {"- , " Main-is: VCtrl"- , "}}"- , ""- , "executable Foo-bar {"- , " Main-is: Foo.hs"- , "}"- ]- expectedResult = - [ F 1 "cabal-version" "3"- , F 3 "description" - "This is a test file\nwith a description longer than two lines."- , IfBlock 5 "os(windows) " - [ F 6 "license" - "You may not use this software\n\nIf you do use this software you will be seeked and destroyed."- ]- []- , IfBlock 10 "os(linux) " - [ F 11 "main-is" "foo1" ] - [ ]- , IfBlock 14 "os(vista) " - [ Section 15 "executable" "RootKit " - [ F 16 "main-is" "DRMManager.hs"]- ] - [ Section 19 "executable" "VistaRemoteAccess "- [F 20 "main-is" "VCtrl"]- ]- , Section 23 "executable" "Foo-bar " - [F 24 "main-is" "Foo.hs"]- ]--test_readFieldsCompat' = case test_readFieldsCompat of- ParseOk _ fs -> mapM_ (putStrLn . show) fs- x -> putStrLn $ "Failed: " ++ show x-test_readFieldsCompat = readFields testPkgDesc- where - testPkgDesc = unlines [- "-- Required",- "Name: Cabal",- "Version: 0.1.1.1.1-rain",- "License: LGPL",- "License-File: foo",- "Copyright: Free Text String",- "Cabal-version: >1.1.1",- "-- Optional - may be in source?",- "Author: Happy Haskell Hacker",- "Homepage: http://www.haskell.org/foo",- "Package-url: http://www.haskell.org/foo",- "Synopsis: a nice package!",- "Description: a really nice package!",- "Category: tools",- "buildable: True",- "CC-OPTIONS: -g -o",- "LD-OPTIONS: -BStatic -dn",- "Frameworks: foo",- "Tested-with: GHC",- "Stability: Free Text String",- "Build-Depends: haskell-src, HUnit>=1.0.0-rain",- "Other-Modules: Distribution.Package, Distribution.Version,",- " Distribution.Simple.GHCPackageConfig",- "Other-files: file1, file2",- "Extra-Tmp-Files: file1, file2",- "C-Sources: not/even/rain.c, such/small/hands",- "HS-Source-Dirs: src, src2",- "Exposed-Modules: Distribution.Void, Foo.Bar",- "Extensions: OverlappingInstances, TypeSynonymInstances",- "Extra-Libraries: libfoo, bar, bang",- "Extra-Lib-Dirs: \"/usr/local/libs\"",- "Include-Dirs: your/slightest, look/will",- "Includes: /easily/unclose, /me, \"funky, path\\\\name\"",- "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"",- "GHC-Options: -fTH -fglasgow-exts",- "Hugs-Options: +TH",- "Nhc-Options: ",- "Jhc-Options: ",- "",- "-- Next is an executable",- "Executable: somescript",- "Main-is: SomeFile.hs",- "Other-Modules: Foo1, Util, Main",- "HS-Source-Dir: scripts",- "Extensions: OverlappingInstances",- "GHC-Options: ",- "Hugs-Options: ",- "Nhc-Options: ",- "Jhc-Options: "- ]-{--test' = do h <- openFile "../Cabal.cabal" ReadMode- s <- hGetContents h- let r = readFields s- case r of- ParseOk _ fs -> mapM_ (putStrLn . show) fs- x -> putStrLn $ "Failed: " ++ show x- putStrLn "==================="- mapM_ (putStrLn . show) $- merge . zip [1..] . lines $ s- hClose h--}---- ghc -DDEBUG --make Distribution/ParseUtils.hs -o test--main :: IO ()-main = do- inputFiles <- getArgs- ok <- mapM checkResult inputFiles-- zipWithM_ summary inputFiles ok- putStrLn $ show (length (filter not ok)) ++ " out of " ++ show (length ok) ++ " failed"-- where summary f True = return ()- summary f False = putStrLn $ f ++ " failed :-("--checkResult :: FilePath -> IO Bool-checkResult inputFile = do- file <- readFile inputFile- case readFields file of- ParseOk _ result -> do- hPutStrLn stderr $ inputFile ++ " parses ok :-)"- return True- ParseFailed err -> do- hPutStrLn stderr $ inputFile ++ " parse failed:"- hPutStrLn stderr $ show err- return False---- -#endif
+ Distribution/ReadE.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.ReadE+-- Copyright : Jose Iborra 2008+--+-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Simple parsing with failure++{- Copyright (c) 2007, Jose Iborra+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.ReadE (+ -- * ReadE+ ReadE(..), succeedReadE, failReadE,+ -- * Projections+ parseReadE, readEOrFail,+ readP_to_E+ ) where++import Data.Either (either)+import Distribution.Compat.ReadP+import Data.Char ( isSpace )++-- | Parser with simple error reporting+newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}+type ErrorMsg = String++instance Functor ReadE where+ fmap f (ReadE p) = ReadE $ \txt -> case p txt of+ Right a -> Right (f a)+ Left err -> Left err++succeedReadE :: (String -> a) -> ReadE a+succeedReadE f = ReadE (Right . f)++failReadE :: ErrorMsg -> ReadE a+failReadE = ReadE . const Left++parseReadE :: ReadE a -> ReadP r a+parseReadE (ReadE p) = do+ txt <- look+ either fail return (p txt)++readEOrFail :: ReadE a -> (String -> a)+readEOrFail r = either error id . runReadE r++readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a+readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt+ , all isSpace s ]+ of [] -> Left (err txt)+ (p:_) -> Right p
Distribution/Simple.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple@@ -58,24 +57,31 @@ -- * Customization UserHooks(..), Args, defaultMainWithHooks, defaultMainWithHooksArgs,- simpleUserHooks, defaultUserHooks, emptyUserHooks,+ -- ** Standard sets of hooks+ simpleUserHooks,+ autoconfUserHooks,+ defaultUserHooks, emptyUserHooks,+ -- ** Utils defaultHookedPackageDesc-#ifdef DEBUG - ,simpleHunitTests-#endif ) where -- local-import Distribution.Simple.Compiler+import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Simple.UserHooks import Distribution.Package --must not specify imports, since we're exporting moule. import Distribution.PackageDescription-import Distribution.Simple.Program(Program(..), ProgramConfiguration,- defaultProgramConfiguration, addKnownProgram,- pfesetupProgram, rawSystemProgramConf)-import Distribution.Simple.PreProcess (knownSuffixHandlers,- removePreprocessedPackage,- preprocessSources, PPSuffixHandler)+ ( PackageDescription(..), GenericPackageDescription+ , updatePackageDescription, hasLibs+ , HookedBuildInfo, emptyHookedBuildInfo+ , readPackageDescription, readHookedBuildInfo )+import Distribution.PackageDescription.Configuration+ ( flattenPackageDescription )+import Distribution.Simple.Program+ ( ProgramConfiguration, defaultProgramConfiguration, addKnownProgram+ , userSpecifyArgs )+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 )@@ -89,192 +95,98 @@ checkPersistBuildConfig, configure, writePersistBuildConfig) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), distPref, srcPref)+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Install (install) import Distribution.Simple.Haddock (haddock, hscolour)-import Distribution.Simple.Utils (die, currentDir, moduleToFilePath,- defaultPackageDesc, defaultHookedPackageDesc)--import Distribution.Simple.Utils (rawSystemPathExit, notice, info)+import Distribution.Simple.Utils+ (die, notice, info, warn, setupMessage, chattyTry,+ defaultPackageDesc, defaultHookedPackageDesc,+ rawSystemExit, cabalVersion ) import Distribution.Verbosity import Language.Haskell.Extension--- Base-import System.Environment(getArgs)-import System.Directory(removeFile, doesFileExist, doesDirectoryExist)--import Distribution.License-import Control.Monad (when, unless)-import Data.List (intersperse, unionBy)-import System.IO.Error (try)-import Distribution.GetOpt--import Distribution.Compat.Directory(removeDirectoryRecursive)-import System.FilePath((</>))--#ifdef DEBUG-import Test.HUnit (Test)-import Distribution.Version hiding (hunitTests)-#else import Distribution.Version-#endif--type Args = [String]---- | WARNING: The hooks interface is under rather constant flux as we--- try to understand users needs. Setup files that depend on this--- interface may break in future releases. Hooks allow authors to add--- specific functionality before and after a command is run, and also--- to specify additional preprocessors.-data UserHooks = UserHooks- {- runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), -- ^Used for @.\/setup test@- readDesc :: IO (Maybe PackageDescription), -- ^Read the description file- hookedPreProcessors :: [ PPSuffixHandler ],- -- ^Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.- hookedPrograms :: [Program],- -- ^These programs are detected at configure time. Arguments for them are added to the configure command.-- -- |Hook to run before configure command- preConf :: Args -> ConfigFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during configure.- confHook :: ( Either GenericPackageDescription PackageDescription- , HookedBuildInfo)- -> ConfigFlags -> IO LocalBuildInfo,- -- |Hook to run after configure command- postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before build command. Second arg indicates verbosity level.- preBuild :: Args -> BuildFlags -> IO HookedBuildInfo,-- -- |Over-ride this hook to gbet different behavior during build.- buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (),- -- |Hook to run after build command. Second arg indicates verbosity level.- postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before makefile command. Second arg indicates verbosity level.- preMakefile :: Args -> MakefileFlags -> IO HookedBuildInfo,-- -- |Over-ride this hook to get different behavior during makefile.- makefileHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> MakefileFlags -> IO (),- -- |Hook to run after makefile command. Second arg indicates verbosity level.- postMakefile :: Args -> MakefileFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before clean command. Second arg indicates verbosity level.- preClean :: Args -> CleanFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during clean.- cleanHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> CleanFlags -> IO (),- -- |Hook to run after clean command. Second arg indicates verbosity level.- postClean :: Args -> CleanFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (),-- -- |Hook to run before copy command- preCopy :: Args -> CopyFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during copy.- copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (),- -- |Hook to run after copy command- postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before install command- preInst :: Args -> InstallFlags -> IO HookedBuildInfo,-- -- |Over-ride this hook to get different behavior during install.- instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (),- -- |Hook to run after install command. postInst should be run- -- on the target, not on the build machine.- postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before sdist command. Second arg indicates verbosity level.- preSDist :: Args -> SDistFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during sdist.- sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (),- -- |Hook to run after sdist command. Second arg indicates verbosity level.- postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (),-- -- |Hook to run before register command- preReg :: Args -> RegisterFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during pfe.- regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),- -- |Hook to run after register command- postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before unregister command- preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during pfe.- unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),- -- |Hook to run after unregister command- postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before hscolour command. Second arg indicates verbosity level.- preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during hscolour.- hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (),- -- |Hook to run after hscolour command. Second arg indicates verbosity level.- postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (),-- -- |Hook to run before haddock command. Second arg indicates verbosity level.- preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during haddock.- haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (),- -- |Hook to run after haddock command. Second arg indicates verbosity level.- postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (),+import Distribution.License+import Distribution.Text+ ( display ) - -- |Hook to run before pfe command. Second arg indicates verbosity level.- prePFE :: Args -> PFEFlags -> IO HookedBuildInfo,- -- |Over-ride this hook to get different behavior during pfe.- pfeHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> PFEFlags -> IO (),- -- |Hook to run after pfe command. Second arg indicates verbosity level.- postPFE :: Args -> PFEFlags -> PackageDescription -> LocalBuildInfo -> IO ()+-- Base+import System.Environment(getArgs,getProgName)+import System.Directory(removeFile, doesFileExist,+ doesDirectoryExist, removeDirectoryRecursive)+import System.Exit - }+import Control.Monad (when)+import Data.List (intersperse, unionBy) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line. defaultMain :: IO ()-defaultMain = defaultMain__ Nothing Nothing Nothing+defaultMain = getArgs >>= defaultMainHelper simpleUserHooks -- | A version of 'defaultMain' that is passed the command line -- arguments, rather than getting them from the environment. defaultMainArgs :: [String] -> IO ()-defaultMainArgs args = defaultMain__ (Just args) Nothing Nothing+defaultMainArgs = defaultMainHelper simpleUserHooks -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO ()-defaultMainWithHooks hooks = defaultMain__ Nothing (Just hooks) Nothing+defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks -- | A customizable version of 'defaultMain' that also takes the command -- line arguments. defaultMainWithHooksArgs :: UserHooks -> [String] -> IO ()-defaultMainWithHooksArgs hooks args- = defaultMain__ (Just args) (Just hooks) Nothing+defaultMainWithHooksArgs = defaultMainHelper -- | Like 'defaultMain', but accepts the package description as input -- rather than using IO to read it. defaultMainNoRead :: PackageDescription -> IO ()-defaultMainNoRead pkg_descr = defaultMain__ Nothing Nothing (Just pkg_descr)+defaultMainNoRead pkg_descr =+ getArgs >>=+ defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } -defaultMain__ :: Maybe [String]- -> Maybe UserHooks- -> Maybe PackageDescription- -> IO ()-defaultMain__ margs mhooks mdescr = do- args <- maybe getArgs return margs- let hooks = maybe simpleUserHooks id mhooks- let prog_conf = allPrograms hooks- (action, args') <- parseGlobalArgs prog_conf args- -- let get_pkg_descr verbosity = case mdescr of--- Just pkg_descr -> return pkg_descr--- Nothing -> do--- maybeDesc <- readDesc hooks--- case maybeDesc of--- Nothing -> defaultPkgDescr--- Just p -> return p--- where--- defaultPkgDescr = do--- -- FIXME: add compat mode or flag to enable configs--- pkg_descr_file <- defaultPackageDesc verbosity --- readPackageDescription verbosity pkg_descr_file- defaultMainWorker mdescr action args' hooks prog_conf+defaultMainHelper :: UserHooks -> Args -> IO ()+defaultMainHelper hooks args =+ case commandsRun globalCommand commands args of+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo (flags, commandParse) ->+ case commandParse of+ _ | fromFlag (globalVersion flags) -> printVersion+ | fromFlag (globalNumericVersion flags) -> printNumericVersion+ CommandHelp help -> printHelp help+ CommandList opts -> printOptionsList opts+ CommandErrors errs -> printErrors errs+ CommandReadyToGo action -> action + where+ printHelp help = getProgName >>= putStr . help+ printOptionsList = putStr . unlines+ printErrors errs = do+ putStr (concat (intersperse "\n" errs))+ exitWith (ExitFailure 1)+ printNumericVersion = putStrLn $ display cabalVersion+ printVersion = putStrLn $ "Cabal library version "+ ++ display cabalVersion++ progs = allPrograms hooks+ commands =+ [configureCommand progs `commandAddAction` configureAction hooks+ ,buildCommand progs `commandAddAction` buildAction hooks+ ,installCommand `commandAddAction` installAction hooks+ ,copyCommand `commandAddAction` copyAction hooks+ ,haddockCommand `commandAddAction` haddockAction hooks+ ,cleanCommand `commandAddAction` cleanAction hooks+ ,sdistCommand `commandAddAction` sdistAction hooks+ ,hscolourCommand `commandAddAction` hscolourAction hooks+ ,registerCommand `commandAddAction` registerAction hooks+ ,unregisterCommand `commandAddAction` unregisterAction hooks+ ,testCommand `commandAddAction` testAction hooks+ ,makefileCommand `commandAddAction` makefileAction hooks+ ]+ -- | Combine the programs in the given hooks with the programs built -- into cabal. allPrograms :: UserHooks@@ -293,200 +205,181 @@ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) --- | Helper function for /defaultMain/-defaultMainWorker :: (Maybe PackageDescription)- -> Action- -> [String]- -> UserHooks- -> ProgramConfiguration- -> IO ()-defaultMainWorker mdescr action all_args hooks prog_conf- = do case action of- ConfigCmd flags -> do- (flags', optFns, args) <-- parseConfigureArgs prog_conf flags all_args [scratchDirOpt]- pbi <- preConf hooks args flags'+configureAction :: UserHooks -> ConfigFlags -> Args -> IO ()+configureAction hooks flags args = do+ let distPref = fromFlag $ configDistPref flags+ pbi <- preConf hooks args flags - (mb_pd_file, pkg_descr0) <- confPkgDescr flags'+ (mb_pd_file, pkg_descr0) <- confPkgDescr - -- get_pkg_descr (configVerbose flags')+ -- get_pkg_descr (configVerbosity flags') --let pkg_descr = updatePackageDescription pbi pkg_descr0 let epkg_descr = (pkg_descr0, pbi) --(warns, ers) <- sanityCheckPackage pkg_descr- --errorOut (configVerbose flags') warns ers+ --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 (foldr id localbuildinfo optFns)+ writePersistBuildConfig distPref localbuildinfo let pkg_descr = localPkgDescr localbuildinfo- postConf hooks args flags' pkg_descr localbuildinfo+ postConf hooks args flags pkg_descr localbuildinfo where- confPkgDescr :: ConfigFlags- -> IO (Maybe FilePath,+ verbosity = fromFlag (configVerbosity flags)+ confPkgDescr :: IO (Maybe FilePath, Either GenericPackageDescription PackageDescription)- confPkgDescr cfgflags =- case mdescr of- Just ppd -> return (Nothing, Right ppd)- Nothing -> do- mdescr' <- readDesc hooks- case mdescr' of- Just descr -> return (Nothing, Right descr)- Nothing -> do- pdfile <- defaultPackageDesc (configVerbose cfgflags)- ppd <- readPackageDescription (configVerbose cfgflags) pdfile- return (Just pdfile, Left ppd)+ confPkgDescr = do+ mdescr <- readDesc hooks+ case mdescr of+ Just descr -> return (Nothing, Right descr)+ Nothing -> do+ pdfile <- defaultPackageDesc verbosity+ ppd <- readPackageDescription verbosity pdfile+ return (Just pdfile, Left ppd) - BuildCmd -> do- lbi <- getBuildConfigIfUpToDate- res@(flags, _, _) <-- parseBuildArgs prog_conf- (emptyBuildFlags (withPrograms lbi)) all_args []- command (\_ _ -> return res) buildVerbose- preBuild buildHook postBuild- (return lbi { withPrograms = buildPrograms flags })+buildAction :: UserHooks -> BuildFlags -> Args -> IO ()+buildAction hooks flags args = do+ let distPref = fromFlag $ buildDistPref flags+ lbi <- getBuildConfigIfUpToDate distPref+ let progs = foldr (uncurry userSpecifyArgs)+ (withPrograms lbi) (buildProgramArgs flags)+ hookedAction preBuild buildHook postBuild+ (return lbi { withPrograms = progs })+ hooks flags args - MakefileCmd ->- command (parseMakefileArgs emptyMakefileFlags) makefileVerbose- preMakefile makefileHook postMakefile- getBuildConfigIfUpToDate+makefileAction :: UserHooks -> MakefileFlags -> Args -> IO ()+makefileAction hooks flags args+ = do let distPref = fromFlag $ makefileDistPref flags+ hookedAction preMakefile makefileHook postMakefile+ (getBuildConfigIfUpToDate distPref)+ hooks flags args - HscolourCmd ->- command (parseHscolourArgs emptyHscolourFlags) hscolourVerbose- preHscolour hscolourHook postHscolour- getBuildConfigIfUpToDate+hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()+hscolourAction hooks flags args+ = do let distPref = fromFlag $ hscolourDistPref flags+ hookedAction preHscolour hscolourHook postHscolour+ (getBuildConfigIfUpToDate distPref)+ hooks flags args - HaddockCmd -> - command (parseHaddockArgs emptyHaddockFlags) haddockVerbose- preHaddock haddockHook postHaddock- getBuildConfigIfUpToDate-- ProgramaticaCmd -> do- command parseProgramaticaArgs pfeVerbose- prePFE pfeHook postPFE- getBuildConfigIfUpToDate-- CleanCmd -> do- (flags, _, args) <- parseCleanArgs emptyCleanFlags all_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 +cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()+cleanAction hooks flags args = do+ let distPref = fromFlag $ cleanDistPref flags pbi <- preClean hooks args flags - mlbi <- maybeGetPersistBuildConfig- pdfile <- defaultPackageDesc (cleanVerbose flags)- ppd <- readPackageDescription (cleanVerbose flags) pdfile+ mlbi <- maybeGetPersistBuildConfig distPref+ pdfile <- defaultPackageDesc verbosity+ ppd <- readPackageDescription verbosity pdfile let pkg_descr0 = flattenPackageDescription ppd let pkg_descr = updatePackageDescription pbi pkg_descr0 cleanHook hooks pkg_descr mlbi hooks flags postClean hooks args flags pkg_descr mlbi-- CopyCmd mprefix -> do- command (parseCopyArgs (emptyCopyFlags mprefix)) copyVerbose- preCopy copyHook postCopy- getBuildConfigIfUpToDate+ where verbosity = fromFlag (cleanVerbosity flags) - InstallCmd -> do- command (parseInstallArgs emptyInstallFlags) installVerbose- preInst instHook postInst- getBuildConfigIfUpToDate+copyAction :: UserHooks -> CopyFlags -> Args -> IO ()+copyAction hooks flags args+ = do let distPref = fromFlag $ copyDistPref flags+ hookedAction preCopy copyHook postCopy+ (getBuildConfigIfUpToDate distPref)+ hooks flags args - SDistCmd -> do- (flags, _, args) <- parseSDistArgs all_args []+installAction :: UserHooks -> InstallFlags -> Args -> IO ()+installAction hooks flags args+ = do let distPref = fromFlag $ installDistPref flags+ hookedAction preInst instHook postInst+ (getBuildConfigIfUpToDate distPref)+ hooks flags args +sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()+sdistAction hooks flags args = do+ let distPref = fromFlag $ sDistDistPref flags pbi <- preSDist hooks args flags - mlbi <- maybeGetPersistBuildConfig- pdfile <- defaultPackageDesc (sDistVerbose flags)- ppd <- readPackageDescription (sDistVerbose flags) pdfile+ mlbi <- maybeGetPersistBuildConfig distPref+ pdfile <- defaultPackageDesc verbosity+ ppd <- readPackageDescription verbosity pdfile let pkg_descr0 = flattenPackageDescription ppd let pkg_descr = updatePackageDescription pbi pkg_descr0 sDistHook hooks pkg_descr mlbi hooks flags postSDist hooks args flags pkg_descr mlbi+ where verbosity = fromFlag (sDistVerbosity flags) - TestCmd -> do- (_verbosity,_, args) <- parseTestArgs all_args []- localbuildinfo <- getBuildConfigIfUpToDate+testAction :: UserHooks -> TestFlags -> Args -> IO ()+testAction hooks flags args = do+ let distPref = fromFlag $ testDistPref flags+ localbuildinfo <- getBuildConfigIfUpToDate distPref let pkg_descr = localPkgDescr localbuildinfo runTests hooks args False pkg_descr localbuildinfo - RegisterCmd -> do- command (parseRegisterArgs emptyRegisterFlags) regVerbose- preReg regHook postReg- getBuildConfigIfUpToDate-- UnregisterCmd -> do- command (parseUnregisterArgs emptyRegisterFlags) regVerbose- preUnreg unregHook postUnreg- getBuildConfigIfUpToDate-- HelpCmd -> return () -- this is handled elsewhere- where- command parse_args _get_verbosity- pre_hook cmd_hook post_hook- get_build_config = do- (flags, _, args) <- parse_args all_args []- pbi <- pre_hook hooks args flags- localbuildinfo <- get_build_config- let pkg_descr0 = localPkgDescr localbuildinfo- --pkg_descr0 <- get_pkg_descr (get_verbose flags)- let pkg_descr = updatePackageDescription pbi pkg_descr0- -- XXX: should we write the modified package descr back to the- -- localbuildinfo?- cmd_hook hooks pkg_descr localbuildinfo hooks flags- post_hook hooks args flags pkg_descr localbuildinfo+registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()+registerAction hooks flags args+ = do let distPref = fromFlag $ regDistPref flags+ hookedAction preReg regHook postReg+ (getBuildConfigIfUpToDate 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)+ hooks flags args ---TODO: where to put this? it's duplicated in .Haddock too-getModulePaths :: LocalBuildInfo -> BuildInfo -> [String] -> IO [FilePath]-getModulePaths lbi bi =- fmap concat .- mapM (flip (moduleToFilePath (buildDir lbi : hsSourceDirs bi)) ["hs", "lhs"])+hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)+ -> (UserHooks -> PackageDescription -> LocalBuildInfo+ -> UserHooks -> flags -> IO ())+ -> (UserHooks -> Args -> flags -> PackageDescription+ -> LocalBuildInfo -> IO ())+ -> IO LocalBuildInfo+ -> UserHooks -> flags -> Args -> IO ()+hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do+ pbi <- pre_hook hooks args flags+ localbuildinfo <- get_build_config+ let pkg_descr0 = localPkgDescr localbuildinfo+ --pkg_descr0 <- get_pkg_descr (get_verbose flags)+ let pkg_descr = updatePackageDescription pbi pkg_descr0+ -- XXX: should we write the modified package descr back to the+ -- localbuildinfo?+ cmd_hook hooks pkg_descr localbuildinfo hooks flags+ post_hook hooks args flags pkg_descr localbuildinfo -getBuildConfigIfUpToDate :: IO LocalBuildInfo-getBuildConfigIfUpToDate = do- lbi <- getPersistBuildConfig+getBuildConfigIfUpToDate :: FilePath -> IO LocalBuildInfo+getBuildConfigIfUpToDate distPref = do+ lbi <- getPersistBuildConfig distPref case pkgDescrFile lbi of Nothing -> return ()- Just pkg_descr_file -> checkPersistBuildConfig pkg_descr_file+ Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file return lbi -- ----------------------------------------------------------------------------- Programmatica support--pfe :: PackageDescription -> LocalBuildInfo -> UserHooks -> PFEFlags -> IO ()-pfe pkg_descr _lbi hooks (PFEFlags verbosity) = do- let pps = allSuffixHandlers hooks- unless (hasLibs pkg_descr) $- die "no libraries found in this project"- withLib pkg_descr () $ \lib -> do- lbi <- getPersistBuildConfig- let bi = libBuildInfo lib- let mods = exposedModules lib ++ otherModules (libBuildInfo lib)- preprocessSources pkg_descr lbi False verbosity pps- inFiles <- getModulePaths lbi bi mods- let verbFlags = if verbosity >= deafening then ["-v"] else []- rawSystemProgramConf verbosity pfesetupProgram (withPrograms lbi)- ("noplogic" : "cpp" : verbFlags ++ inFiles)----- -------------------------------------------------------------------------- -- Cleaning -clean :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> CleanFlags -> IO ()-clean pkg_descr maybeLbi _ (CleanFlags saveConfigure verbosity) = do+clean :: PackageDescription -> CleanFlags -> IO ()+clean pkg_descr flags = do+ let distPref = fromFlag $ cleanDistPref flags notice verbosity "cleaning..." - maybeConfig <- if saveConfigure then maybeGetPersistBuildConfig- else return Nothing+ maybeConfig <- if fromFlag (cleanSaveConf flags)+ then maybeGetPersistBuildConfig distPref+ else return Nothing -- remove the whole dist/ directory rather than tracking exactly what files -- we created in there.- try $ removeDirectoryRecursive distPref+ chattyTry "removing dist/" $ do+ exists <- doesDirectoryExist distPref+ when exists (removeDirectoryRecursive distPref) -- these live in the top level dir so must be removed separately removeRegScripts@@ -494,22 +387,10 @@ -- Any extra files the user wants to remove mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) - -- FIXME: put all JHC's generated files under dist/ so they get cleaned- case maybeLbi of- Nothing -> return ()- Just lbi -> do- case compilerFlavor (compiler lbi) of- JHC -> cleanJHCExtras lbi- _ -> return ()- -- If the user wanted to save the config, write it back- maybe (return ()) writePersistBuildConfig maybeConfig+ maybe (return ()) (writePersistBuildConfig distPref) maybeConfig where- -- JHC FIXME remove exe-sources- cleanJHCExtras lbi = do- try $ removeFile (buildDir lbi </> "jhc-pkg.conf")- removePreprocessedPackage pkg_descr currentDir ["ho"] removeFileOrDirectory :: FilePath -> IO () removeFileOrDirectory fname = do isDir <- doesDirectoryExist fname@@ -517,70 +398,11 @@ if isDir then removeDirectoryRecursive fname else if isFile then removeFile fname else return ()+ verbosity = fromFlag (cleanVerbosity flags) -- -------------------------------------------------------------------------- -- Default hooks -no_extra_flags :: [String] -> IO ()-no_extra_flags [] = return ()-no_extra_flags extra_flags =- die $ concat- $ intersperse "\n" ("Unrecognised flags:" : map (' ' :) extra_flags)--scratchDirOpt :: OptDescr (LocalBuildInfo -> LocalBuildInfo)-scratchDirOpt = Option "b" ["scratchdir"] (reqDirArg setScratchDir)- "directory to receive the built package [dist/scratch]"- where setScratchDir dir lbi = lbi { scratchDir = dir }---- |Empty 'UserHooks' which do nothing.-emptyUserHooks :: UserHooks-emptyUserHooks- = UserHooks- {- runTests = ru,- readDesc = return Nothing,- hookedPreProcessors = [],- hookedPrograms = [],- preConf = rn,- confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),- postConf = ru,- preBuild = rn,- buildHook = ru,- postBuild = ru,- preMakefile = rn,- makefileHook = ru,- postMakefile = ru,- preClean = rn,- cleanHook = ru,- postClean = ru,- preCopy = rn,- copyHook = ru,- postCopy = ru,- preInst = rn,- instHook = ru,- postInst = ru,- preSDist = rn,- sDistHook = ru,- postSDist = ru,- preReg = rn,- regHook = ru,- postReg = ru,- preUnreg = rn,- unregHook = ru,- postUnreg = ru,- prePFE = rn,- pfeHook = ru,- postPFE = ru,- preHscolour = rn,- hscolourHook = ru,- postHscolour = ru,- preHaddock = rn,- haddockHook = ru,- postHaddock = ru- }- where rn args _ = no_extra_flags args >> return emptyHookedBuildInfo- ru _ _ _ _ = return ()- -- | Hooks that correspond to a plain instantiation of the -- \"simple\" build system simpleUserHooks :: UserHooks@@ -591,11 +413,10 @@ makefileHook = defaultMakefileHook, copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params instHook = defaultInstallHook,- sDistHook = \p l h f -> sdist p l f srcPref distPref (allSuffixHandlers h),- pfeHook = pfe,- cleanHook = clean,- hscolourHook = defaultHscolourHook,- haddockHook = defaultHaddockHook,+ sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),+ cleanHook = \p _ _ f -> clean p f,+ hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,+ haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, regHook = defaultRegHook, unregHook = \p l _ f -> unregister p l f }@@ -614,93 +435,98 @@ -- FIXME: do something sensible for windows, or do nothing in postConf. defaultUserHooks :: UserHooks-defaultUserHooks = autoconfUserHooks+defaultUserHooks = autoconfUserHooks {+ confHook = \pkg flags -> do+ 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:+ -- http://hackage.haskell.org/trac/hackage/ticket/165+ where oldCompatPostConf args flags _ _+ = do let verbosity = fromFlag (configVerbosity flags)+ noExtraFlags args+ confExists <- doesFileExist "configure"+ when confExists $+ rawSystemExit verbosity "sh" $+ "configure" : configureArgs backwardsCompatHack flags+ backwardsCompatHack = True autoconfUserHooks :: UserHooks autoconfUserHooks = simpleUserHooks {- postConf = defaultPostConf,- preBuild = readHook buildVerbose,- preMakefile = readHook makefileVerbose,- preClean = readHook cleanVerbose,- preCopy = readHook copyVerbose,- preInst = readHook installVerbose,- preHscolour = readHook hscolourVerbose,- preHaddock = readHook haddockVerbose,- preReg = readHook regVerbose,- preUnreg = readHook regVerbose+ postConf = defaultPostConf,+ preBuild = readHook buildVerbosity,+ preMakefile = readHook makefileVerbosity,+ preClean = readHook cleanVerbosity,+ preCopy = readHook copyVerbosity,+ preInst = readHook installVerbosity,+ preHscolour = readHook hscolourVerbosity,+ preHaddock = readHook haddockVerbosity,+ preReg = readHook regVerbosity,+ preUnreg = readHook regVerbosity } where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () defaultPostConf args flags _ _- = do let verbosity = configVerbose flags- no_extra_flags args+ = do let verbosity = fromFlag (configVerbosity flags)+ noExtraFlags args confExists <- doesFileExist "configure"- when confExists $- rawSystemPathExit verbosity "sh" $- "configure" : configureArgs flags+ if confExists+ then rawSystemExit verbosity "sh" $+ "configure"+ : configureArgs backwardsCompatHack flags+ else die "configure script not found."+ backwardsCompatHack = False - readHook :: (a -> Verbosity) -> Args -> a -> IO HookedBuildInfo+ readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo readHook get_verbosity a flags = do- no_extra_flags a+ noExtraFlags a maybe_infoFile <- defaultHookedPackageDesc case maybe_infoFile of Nothing -> return emptyHookedBuildInfo Just infoFile -> do- let verbosity = get_verbosity flags+ let verbosity = fromFlag (get_verbosity flags) info verbosity $ "Reading parameters from " ++ infoFile readHookedBuildInfo verbosity infoFile defaultInstallHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()-defaultInstallHook pkg_descr localbuildinfo _ (InstallFlags uInstFlag verbosity) = do- install pkg_descr localbuildinfo (CopyFlags NoCopyDest verbosity)+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- emptyRegisterFlags{ regPackageDB=uInstFlag, regVerbose=verbosity }+ register pkg_descr localbuildinfo defaultRegisterFlags {+ regPackageDB = installPackageDB flags,+ regVerbosity = installVerbosity flags+ } defaultBuildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags = do+ let distPref = fromFlag $ buildDistPref flags build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) when (hasLibs pkg_descr) $- writeInstalledConfig pkg_descr localbuildinfo False Nothing+ writeInstalledConfig distPref pkg_descr localbuildinfo False Nothing defaultMakefileHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> MakefileFlags -> IO () defaultMakefileHook pkg_descr localbuildinfo hooks flags = do+ let distPref = fromFlag $ makefileDistPref flags makefile pkg_descr localbuildinfo flags (allSuffixHandlers hooks) when (hasLibs pkg_descr) $- writeInstalledConfig pkg_descr localbuildinfo False Nothing+ writeInstalledConfig distPref pkg_descr localbuildinfo False Nothing defaultRegHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () defaultRegHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags- else setupMessage (regVerbose flags)- "Package contains no library to register:"- pkg_descr--defaultHaddockHook :: PackageDescription -> LocalBuildInfo- -> UserHooks -> HaddockFlags -> IO ()-defaultHaddockHook pkg_descr localbuildinfo hooks flags = do- haddock pkg_descr localbuildinfo (allSuffixHandlers hooks) flags--defaultHscolourHook :: PackageDescription -> LocalBuildInfo- -> UserHooks -> HscolourFlags -> IO ()-defaultHscolourHook pkg_descr localbuildinfo hooks flags =- hscolour pkg_descr localbuildinfo (allSuffixHandlers hooks) flags---- --------------------------------------------------------------- * Utils--- ----------------------------------------------------------------- --------------------------------------------------------------- * Testing--- -------------------------------------------------------------#ifdef DEBUG-simpleHunitTests :: [Test]-simpleHunitTests = []-#endif+ else setupMessage verbosity+ "Package contains no library to register:" (packageId pkg_descr)+ where verbosity = fromFlag (regVerbosity flags)
Distribution/Simple/Build.hs view
@@ -1,9 +1,8 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build -- Copyright : Isaac Jones 2003-2005--- +-- -- Maintainer : Isaac Jones <ijones@syntaxpolice.org> -- Stability : alpha -- Portability : portable@@ -44,27 +43,27 @@ module Distribution.Simple.Build ( build, makefile, initialBuildSteps-#ifdef DEBUG - ,hunitTests-#endif ) where -import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..) )-import Distribution.PackageDescription +import Distribution.Simple.Compiler+ ( CompilerFlavor(..), compilerFlavor )+import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..),- setupMessage, Executable(..), Library(..), - autogenModuleName )-import Distribution.Package ( PackageIdentifier(..), showPackageId )-import Distribution.Simple.Setup ( CopyDest(..), BuildFlags(..), - MakefileFlags(..) )+ Executable(..), Library(..) )+import Distribution.Package+ ( Package(..), packageName, packageVersion )+import Distribution.Simple.Setup ( CopyDest(..), 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 )-import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, die )+import Distribution.Simple.Utils+ ( createDirectoryIfMissingVerbose, die, setupMessage, writeUTF8File ) import Distribution.System import System.FilePath ( (</>), pathSeparator )@@ -80,10 +79,8 @@ import Distribution.PackageDescription (hasLibs) import Distribution.Verbosity--#ifdef DEBUG-import Test.HUnit (Test)-#endif+import Distribution.Text+ ( display ) -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package.@@ -94,9 +91,10 @@ -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling -> IO () build pkg_descr lbi flags suffixes = do- let verbosity = buildVerbose flags- initialBuildSteps pkg_descr lbi verbosity suffixes- setupMessage verbosity "Building" pkg_descr+ let distPref = fromFlag (buildDistPref flags)+ verbosity = fromFlag (buildVerbosity flags)+ initialBuildSteps distPref pkg_descr lbi verbosity suffixes+ setupMessage verbosity "Building" (packageId pkg_descr) case compilerFlavor (compiler lbi) of GHC -> GHC.build pkg_descr lbi verbosity JHC -> JHC.build pkg_descr lbi verbosity@@ -110,35 +108,37 @@ -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling -> IO () makefile pkg_descr lbi flags suffixes = do- let verb = makefileVerbose flags- initialBuildSteps pkg_descr lbi verb suffixes+ let distPref = fromFlag (makefileDistPref flags)+ verbosity = fromFlag (makefileVerbosity flags)+ initialBuildSteps distPref pkg_descr lbi verbosity suffixes when (not (hasLibs pkg_descr)) $ die ("Makefile is only supported for libraries, currently.")- setupMessage verb "Generating Makefile" pkg_descr+ setupMessage verbosity "Generating Makefile" (packageId pkg_descr) case compilerFlavor (compiler lbi) of GHC -> GHC.makefile pkg_descr lbi flags _ -> die ("Generating a Makefile is not supported for this compiler.") -initialBuildSteps :: PackageDescription -- ^mostly information from the .cabal file+initialBuildSteps :: FilePath -- ^"dist" prefix+ -> PackageDescription -- ^mostly information from the .cabal file -> LocalBuildInfo -- ^Configuration information -> Verbosity -- ^The verbosity to use -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling -> IO ()-initialBuildSteps 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)) ++ map buildInfo (executables pkg_descr) unless (any buildable buildInfos) $ do- let name = showPackageId (package pkg_descr)+ let name = display (packageId pkg_descr) die ("Package " ++ name ++ " can't be built on this system.") createDirectoryIfMissingVerbose verbosity True (buildDir lbi) -- construct and write the Paths_<pkg>.hs file createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)- buildPathsModule pkg_descr lbi+ buildPathsModule distPref pkg_descr lbi preprocessSources pkg_descr lbi False verbosity suffixes @@ -150,13 +150,14 @@ autogenModulesDir :: LocalBuildInfo -> String autogenModulesDir lbi = buildDir lbi </> "autogen" -buildPathsModule :: PackageDescription -> LocalBuildInfo -> IO ()-buildPathsModule pkg_descr lbi =+buildPathsModule :: FilePath -> PackageDescription -> LocalBuildInfo -> IO ()+buildPathsModule distPref pkg_descr lbi = let pragmas | absolute || isHugs = "" | otherwise =- "{-# OPTIONS_GHC -fffi #-}\n"++- "{-# LANGUAGE ForeignFunctionInterface #-}\n"+ "{-# LANGUAGE ForeignFunctionInterface #-}\n" +++ "{-# OPTIONS_GHC -fffi #-}\n"+++ "{-# OPTIONS_JHC -fffi #-}\n" foreign_imports | absolute = ""@@ -175,10 +176,11 @@ "\t) where\n"++ "\n"++ foreign_imports++- "import Data.Version"+++ "import Data.Version (Version(..))\n"+++ "import System.Environment (getEnv)"++ "\n"++ "\nversion :: Version"++- "\nversion = " ++ show (pkgVersion (package pkg_descr))+++ "\nversion = " ++ show (packageVersion pkg_descr)++ "\n" body@@ -190,13 +192,15 @@ "\nlibexecdir = " ++ show flat_libexecdir ++ "\n"++ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++- "getBinDir = return bindir\n"++- "getLibDir = return libdir\n"++- "getDataDir = return datadir\n"++- "getLibexecDir = return libexecdir\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 = return (datadir ++ "++path_sep++" ++ name)\n"+ "getDataFileName name = do\n"+++ " dir <- getDataDir\n"+++ " return (dir ++ "++path_sep++" ++ name)\n" | otherwise = "\nprefix = " ++ show flat_prefix ++ "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++@@ -206,7 +210,8 @@ "getLibDir :: IO FilePath\n"++ "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ "getDataDir :: IO FilePath\n"++- "getDataDir = "++mkGetDir flat_datadir flat_datadirrel++"\n\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"++@@ -217,13 +222,13 @@ get_prefix_stuff++ "\n"++ filename_stuff- in do btime <- getModificationTime localBuildInfoFile+ in do btime <- getModificationTime (localBuildInfoFile distPref) exists <- doesFileExist paths_filepath ptime <- if exists then getModificationTime paths_filepath else return btime if btime >= ptime- then writeFile paths_filepath (header++body)+ then writeUTF8File paths_filepath (header++body) else return () where InstallDirs {@@ -240,10 +245,14 @@ 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@@ -251,8 +260,8 @@ || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) supportsRelocatableProgs Hugs = True- supportsRelocatableProgs GHC = case os of- Windows _ -> True+ supportsRelocatableProgs GHC = case buildOS of+ Windows -> True _ -> False supportsRelocatableProgs _ = False @@ -327,20 +336,11 @@ " _ -> path1\n"++ "\n"++ "pathSeparator :: Char\n"++- (case os of- Windows _ -> "pathSeparator = '\\\\'\n"+ (case buildOS of+ Windows -> "pathSeparator = '\\\\'\n" _ -> "pathSeparator = '/'\n") ++ "\n"++ "isPathSeparator :: Char -> Bool\n"++- (case os of- Windows _ -> "isPathSeparator c = c == '/' || c == '\\\\'\n"+ (case buildOS of+ Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" _ -> "isPathSeparator c = c == '/'\n")---- --------------------------------------------------------------- * Testing--- --------------------------------------------------------------#ifdef DEBUG-hunitTests :: [Test]-hunitTests = []-#endif
+ Distribution/Simple/BuildPaths.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.BuildPaths+-- Copyright : Isaac Jones 2003-2004,+-- Duncan Coutts 2008+--+-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- A bunch of dirs, paths and file names used for intermediate build steps.+--++{- 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.Simple.BuildPaths (+ defaultDistPref, srcPref,+ hscolourPref, haddockPref,+ autogenModulesDir,++ autogenModuleName,+ haddockName,++ mkLibName,+ mkProfLibName,+ mkSharedLibName,++ exeExtension,+ objExtension,+ dllExtension,++ ) where+++import System.FilePath (FilePath, (</>), (<.>))++import Distribution.Package+ ( PackageIdentifier, packageName )+import Distribution.Compiler+ ( CompilerId(..) )+import Distribution.PackageDescription (PackageDescription)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir))+import Distribution.Simple.Setup (defaultDistPref)+import Distribution.Text+ ( display )+import Distribution.System (OS(..), buildOS)++-- ---------------------------------------------------------------------------+-- Build directories and files++srcPref :: FilePath -> FilePath+srcPref distPref = distPref </> "src"++hscolourPref :: FilePath -> PackageDescription -> FilePath+hscolourPref = haddockPref++haddockPref :: FilePath -> PackageDescription -> FilePath+haddockPref distPref pkg_descr+ = distPref </> "doc" </> "html" </> packageName pkg_descr++-- |The directory in which we put auto-generated modules+autogenModulesDir :: LocalBuildInfo -> String+autogenModulesDir lbi = buildDir lbi </> "autogen"+++-- |The name of the auto-generated module associated with a package+autogenModuleName :: PackageDescription -> String+autogenModuleName pkg_descr =+ "Paths_" ++ map fixchar (packageName pkg_descr)+ where fixchar '-' = '_'+ fixchar c = c++haddockName :: PackageDescription -> FilePath+haddockName pkg_descr = packageName pkg_descr <.> "haddock"++-- ---------------------------------------------------------------------------+-- Library file names++mkLibName :: PackageIdentifier -> String+mkLibName lib = "libHS" ++ display lib <.> "a"++mkProfLibName :: PackageIdentifier -> String+mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a"++-- Implement proper name mangling for dynamical shared objects+-- libHS<packagename>-<compilerFlavour><compilerVersion>+-- e.g. libHSbase-2.1-ghc6.6.1.so+mkSharedLibName :: PackageIdentifier -> CompilerId -> String+mkSharedLibName lib (CompilerId compilerFlavor compilerVersion)+ = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension+ where comp = display compilerFlavor ++ display compilerVersion++-- ------------------------------------------------------------+-- * Platform file extensions+-- ------------------------------------------------------------ ++-- ToDo: This should be determined via autoconf (AC_EXEEXT)+-- | Extension for executable files+-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)+exeExtension :: String+exeExtension = case buildOS of+ Windows -> "exe"+ _ -> ""++-- ToDo: This should be determined via autoconf (AC_OBJEXT)+-- | Extension for object files. For GHC and NHC the extension is @\"o\"@.+-- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.+objExtension :: String+objExtension = "o"++-- | Extension for dynamically linked (or shared) libraries+-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)+dllExtension :: String+dllExtension = case buildOS of+ Windows -> "dll"+ OSX -> "dylib"+ _ -> "so"
+ Distribution/Simple/Command.hs view
@@ -0,0 +1,527 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Command+-- Copyright : Duncan Coutts 2007+-- +-- Maintainer : Duncan Coutts <duncan@haskell.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Data types and parser for the standard command-line+-- setup.++{- 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.Simple.Command (++ -- * Command interface+ CommandUI(..),+ commandShowOptions,+ + -- ** Constructing commands+ ShowOrParseArgs(..),+ makeCommand,++ -- ** Associating actions with commands+ Command,+ commandAddAction,+ noExtraFlags,+ + -- ** Running commands+ CommandParse(..),+ commandsRun,++-- * Option Fields+ OptionField(..), Name,++-- ** Constructing Option Fields+ option, multiOption,++-- ** Liftings & Projections+ liftOption, viewAsFieldDescr,++-- * Option Descriptions+ OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,++-- ** OptDescr 'smart' constructors+ MkOptDescr,+ reqArg, reqArg', optArg, optArg', noArg,+ boolOpt, boolOpt', choiceOpt, choiceOptFromEnum++ ) where++import Control.Monad+import Data.Char (isAlpha, toLower)+import Data.List (sortBy)+import Data.Maybe+import Data.Monoid+import qualified Distribution.GetOpt as GetOpt+import Distribution.Text+ ( Text(disp, parse) )+import Distribution.ParseUtils+import Distribution.ReadE+import Distribution.Simple.Utils (die, intercalate)+import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty)++data CommandUI flags = CommandUI {+ -- | The name of the command as it would be entered on the command line.+ -- For example @\"build\"@.+ commandName :: String,+ -- | A short, one line description of the command to use in help texts.+ commandSynopsis :: String,+ -- | The useage line summary for this command+ commandUsage :: String -> String,+ -- | Additional explanation of the command to use in help texts.+ commandDescription :: Maybe (String -> String),+ -- | Initial \/ empty flags+ commandDefaultFlags :: flags,+ -- | All the Option fields for this command+ commandOptions :: ShowOrParseArgs -> [OptionField flags]+ }++data ShowOrParseArgs = ShowArgs | ParseArgs++type Name = String+type Description = String++-- | We usually have a datatype for storing configuration values, where+-- every field stores a configuration option, and the user sets+-- the value either via command line flags or a configuration file.+-- An individual OptionField models such a field, and we usually+-- build a list of options associated to a configuration datatype.+data OptionField a = OptionField {+ optionName :: Name,+ optionDescr :: [OptDescr a] }++-- | An OptionField takes one or more OptDescrs, describing the command line interface for the field.+data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String])+ | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String])+ | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]+ | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool)++-- | Short command line option strings+type SFlags = [Char]+-- | Long command line option strings+type LFlags = [String]+type OptFlags = (SFlags,LFlags)+type ArgPlaceHolder = String+++-- | Create an option taking a single OptDescr.+-- No explicit Name is given for the Option, the name is the first LFlag given.+option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a+option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]+option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag"++-- | Create an option taking several OptDescrs.+-- You will have to give the flags and description individually to the OptDescr constructor.+multiOption :: Name -> get -> set+ -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description.+ -> OptionField a+multiOption n get set args = OptionField n [arg get set | arg <- args]++type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a++-- | Create a string-valued command line interface.+reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])+ -> MkOptDescr (a -> b) (b -> a -> a) a+reqArg ad mkflag showflag sf lf d get set =+ ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get)++-- | Create a string-valued command line interface with a default value.+optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])+ -> MkOptDescr (a -> b) (b -> a -> a) a+optArg ad mkflag def showflag sf lf d get set =+ OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)+ (\b -> set (get b `mappend` def) b)+ (showflag . get)++-- | (String -> a) variant of "reqArg"+reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String])+ -> MkOptDescr (a -> b) (b -> a -> a) a+reqArg' ad mkflag showflag =+ reqArg ad (succeedReadE mkflag) showflag++-- | (String -> a) variant of "optArg"+optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String])+ -> MkOptDescr (a -> b) (b -> a -> a) a+optArg' ad mkflag showflag =+ optArg ad (succeedReadE (mkflag . Just)) def showflag+ where def = mkflag Nothing++noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a+noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d++boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt g s sfT sfF _sf _lf@(n:_) d get set =+ BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)+boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable"++boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)++-- | create a Choice option+choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a+choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts+ where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]++-- | create a Choice option out of an enumeration type.+-- As long flags, the Show output is used. As short flags, the first character+-- which does not conflict with a previous one is used.+choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a+choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d')+ | (x, sf) <- sflags'+ , let d' = d ++ show x]+ _sf _lf d get+ where sflags' = foldl f [] [firstOne..]+ f prev x = let prevflags = concatMap snd prev in+ prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf+ , toLower sf `notElem` prevflags]+ firstOne = minBound `asTypeOf` get undefined++commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)]+commandGetOpts showOrParse command =+ concatMap viewAsGetOpt (commandOptions command showOrParse)++viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)]+viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa+ where+ optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =+ [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d]+ where set' = readEOrFail set+ optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) =+ [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]+ where set' Nothing = def+ set' (Just txt) = readEOrFail set txt+ optDescrToGetOpt (ChoiceOpt alts) =+ [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]+ optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =+ [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)+ , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]++-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one.+viewAsFieldDescr :: OptionField a -> FieldDescr a+viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected"+viewAsFieldDescr (OptionField n dd) = FieldDescr n get set+ where optDescr = head $ sortBy cmp dd+ ReqArg{} `cmp` ReqArg{} = EQ+ ReqArg{} `cmp` _ = GT+ BoolOpt{} `cmp` ReqArg{} = LT+ BoolOpt{} `cmp` BoolOpt{} = EQ+ BoolOpt{} `cmp` _ = GT+ ChoiceOpt{} `cmp` ReqArg{} = LT+ ChoiceOpt{} `cmp` BoolOpt{} = LT+ ChoiceOpt{} `cmp` ChoiceOpt{} = EQ+ ChoiceOpt{} `cmp` _ = GT+ OptArg{} `cmp` OptArg{} = EQ+ OptArg{} `cmp` _ = LT+ get t = case optDescr of+ ReqArg _ _ _ _ ppr ->+ (cat . punctuate comma . map text . ppr) t+ OptArg _ _ _ _ _ ppr ->+ case ppr t of+ [] -> empty+ (Nothing : _) -> text "True"+ (Just a : _) -> text a+ ChoiceOpt alts ->+ fromMaybe empty $ listToMaybe+ [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]+ BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t+ set line val a =+ case optDescr of+ ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val+ -- We parse for a single value instead of a list,+ -- as one can't really implement parseList :: ReadE a -> ReadE [a]+ -- with the current ReadE definition+ ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of+ Just f -> return (f a)+ _ -> syntaxError line val+ BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val+ OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far,+ -- so we avoid future surprises by not implementing it.+ error "Command.optionToFieldDescr: feature not implemented"++getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)+getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts+ , lf == val]++getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option"++getCurrentChoice :: OptDescr a -> a -> [String]+getCurrentChoice (ChoiceOpt alts) a =+ [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a]++getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr"+++liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b+liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}+++liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b+liftOptDescr get' set' (ChoiceOpt opts) =+ ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get'))+ | (d, ff, set, get) <- opts]++liftOptDescr get' set' (OptArg d ff ad set def get) =+ OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get')++liftOptDescr get' set' (ReqArg d ff ad set get) =+ ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')++liftOptDescr get' set' (BoolOpt d ffT ffF set get) =+ BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')++liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b+liftSet get' set' set x = set' (set $ get' x) x++-- | Show flags in the standard long option command line format+commandShowOptions :: CommandUI flags -> flags -> [String]+commandShowOptions command v = concat+ [ showOptDescr v od | o <- commandOptions command ParseArgs+ , od <- optionDescr o]+ where+ showOptDescr :: a -> OptDescr a -> [String]+ showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)+ = case enabled x of+ Nothing -> []+ Just True -> ["--" ++ lfT]+ Just False -> ["--" ++ lfF]+ showOptDescr x c@ChoiceOpt{}+ = ["--" ++ val | val <- getCurrentChoice c x]+ showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)+ = [ "--"++lf++"="++flag+ | flag <- showflag x ]+ showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag)+ = [ case flag of+ Just s -> "--"++lf++"="++s+ Nothing -> "--"++lf+ | flag <- showflag x ]+ showOptDescr _ _+ = error "Distribution.Simple.Command.showOptDescr: unreachable"+++commandListOptions :: CommandUI flags -> [String]+commandListOptions command =+ concatMap listOption $+ addCommonFlags ShowArgs $ -- This is a slight hack, we don't want+ -- "--list-options" showing up in the+ -- list options output, so use ShowArgs+ commandGetOpts ShowArgs command+ where+ listOption (GetOpt.Option shortNames longNames _ _) =+ [ "-" ++ [name] | name <- shortNames ]+ ++ [ "--" ++ name | name <- longNames ]++-- | The help text for this command with descriptions of all the options.+commandHelp :: CommandUI flags -> String -> String+commandHelp command pname =+ commandUsage command pname+ ++ (GetOpt.usageInfo ""+ . addCommonFlags ShowArgs+ $ commandGetOpts ShowArgs command)+ ++ case commandDescription command of+ Nothing -> ""+ Just desc -> '\n': desc pname++-- | Make a Command from standard 'GetOpt' options.+makeCommand :: String -- ^ name+ -> String -- ^ short description+ -> Maybe (String -> String) -- ^ long description+ -> flags -- ^ initial\/empty flags+ -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options+ -> CommandUI flags+makeCommand name shortDesc longDesc defaultFlags options =+ CommandUI {+ commandName = name,+ commandSynopsis = shortDesc,+ commandDescription = longDesc,+ commandUsage = usage,+ commandDefaultFlags = defaultFlags,+ commandOptions = options+ }+ where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"+ ++ "Flags for " ++ name ++ ":"++-- | Common flags that apply to every command+data CommonFlag = HelpFlag | ListOptionsFlag++commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]+commonFlags showOrParseArgs = case showOrParseArgs of+ ShowArgs -> [help]+ ParseArgs -> [help, list]+ where+ help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag)+ "Show this help text"+ helpShortFlags = case showOrParseArgs of+ ShowArgs -> ['h']+ ParseArgs -> ['h', '?']+ list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag)+ "Print a list of command line flags"++addCommonFlags :: ShowOrParseArgs+ -> [GetOpt.OptDescr a]+ -> [GetOpt.OptDescr (Either CommonFlag a)]+addCommonFlags showOrParseArgs options =+ map (fmapOptDesc Left) (commonFlags showOrParseArgs)+ ++ map (fmapOptDesc Right) options+ where fmapOptDesc f (GetOpt.Option s l d m) =+ GetOpt.Option s l (fmapArgDesc f d) m+ fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a)+ fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d+ fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d+++commandParseArgs :: CommandUI flags -> Bool -> [String]+ -> CommandParse (flags -> flags, [String])+commandParseArgs command ordered args =+ let options = addCommonFlags ParseArgs+ $ commandGetOpts ParseArgs command+ order | ordered = 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++ 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 ]++data CommandParse flags = CommandHelp (String -> String)+ | CommandList [String]+ | CommandErrors [String]+ | CommandReadyToGo flags+instance Functor CommandParse where+ fmap _ (CommandHelp help) = CommandHelp help+ fmap _ (CommandList opts) = CommandList opts+ fmap _ (CommandErrors errs) = CommandErrors errs+ fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)+++data Command action = Command String String ([String] -> CommandParse action)++commandAddAction :: Monoid flags+ => CommandUI flags+ -> (flags -> [String] -> action)+ -> Command action+commandAddAction command action =+ Command (commandName command)+ (commandSynopsis command)+ (fmap (uncurry applyDefaultArgs)+ . commandParseArgs command False)++ where applyDefaultArgs mkflags args =+ let flags = commandDefaultFlags command+ `mappend` mkflags mempty+ in action flags args++commandsRun :: CommandUI a+ -> [Command action]+ -> [String]+ -> CommandParse (a, CommandParse action)+commandsRun globalCommand commands args =+ case commandParseArgs globalCommand' True args of+ CommandHelp help -> CommandHelp help+ CommandList opts -> CommandList (opts ++ commandNames)+ CommandErrors errs -> CommandErrors errs+ CommandReadyToGo (mkflags, args') -> case args' of+ ("help":cmdArgs) -> handleHelpCommand cmdArgs+ (name:cmdArgs) -> case lookupCommand name of+ [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs)+ _ -> CommandReadyToGo (flags, badCommand name)+ [] -> CommandReadyToGo (flags, noCommand)+ where flags = mkflags (commandDefaultFlags globalCommand)++ where+ lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands'+ , cname'==cname ]+ noCommand = CommandErrors ["no command given (try --help)\n"]+ badCommand cname = CommandErrors ["unrecognised command: " ++ cname+ ++ " (try --help)\n"]+ commands' = commands ++ [commandAddAction helpCommandUI undefined]+ commandNames = [ name | Command name _ _ <- commands' ]+ globalCommand' = globalCommand {+ commandUsage = \pname ->+ "Usage: " ++ pname ++ " [GLOBAL FLAGS]\n"+ ++ " or: " ++ pname ++ " COMMAND [FLAGS]\n\n"+ ++ "Global flags:",+ commandDescription = Just $ \pname ->+ "Commands:\n"+ ++ unlines [ " " ++ align name ++ " " ++ description+ | Command name description _ <- commands' ]+ ++ case commandDescription globalCommand of+ Nothing -> ""+ Just desc -> '\n': desc pname+ }+ where maxlen = maximum [ length name | Command name _ _ <- commands' ]+ align str = str ++ replicate (maxlen - length str) ' '++ -- A bit of a hack: support "prog help" as a synonym of "prog --help"+ -- furthermore, support "prog help command" as "prog command --help"+ handleHelpCommand cmdArgs =+ case commandParseArgs helpCommandUI True cmdArgs of+ CommandHelp help -> CommandHelp help+ CommandList list -> CommandList (list ++ commandNames)+ CommandErrors _ -> CommandHelp globalHelp+ CommandReadyToGo (_,[]) -> CommandHelp globalHelp+ CommandReadyToGo (_,(name:cmdArgs')) ->+ case lookupCommand name of+ [Command _ _ action] ->+ case action ("--help":cmdArgs') of+ CommandHelp help -> CommandHelp help+ CommandList _ -> CommandList []+ _ -> CommandHelp globalHelp+ _ -> badCommand name++ where globalHelp = commandHelp globalCommand'+ helpCommandUI =+ (makeCommand "help" "Help about commands" Nothing () (const [])) {+ commandUsage = \pname ->+ "Usage: " ++ pname ++ " help [FLAGS]\n"+ ++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"+ ++ "Flags for help:"+ }++-- | Utility function, many commands do not accept additional flags. This+-- action fails with a helpful error message if the user supplies any extra.+--+noExtraFlags :: [String] -> IO ()+noExtraFlags [] = return ()+noExtraFlags extraFlags =+ die $ "Unrecognised flags: " ++ intercalate ", " extraFlags+--TODO: eliminate this function and turn it into a variant on commandAddAction+-- instead like commandAddActionNoArgs that doesn't supply the [String]
Distribution/Simple/Compiler.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Compiler@@ -44,44 +43,43 @@ -- * Haskell implementations module Distribution.Compiler, Compiler(..),- showCompilerId, compilerVersion,+ showCompilerId, compilerFlavor, compilerVersion, -- * Support for package databases PackageDB(..), + -- * Support for optimisation levels+ OptimisationLevel(..),+ flagToOptimisationLevel,+ -- * Support for language extensions Flag, extensionsToFlags, unsupportedExtensions-#ifdef DEBUG- ,hunitTests-#endif ) where import Distribution.Compiler import Distribution.Version (Version(..))-import Distribution.Package (PackageIdentifier(..), showPackageId)+import Distribution.Text (display) import Language.Haskell.Extension (Extension(..)) import Data.List (nub) import Data.Maybe (catMaybes, isNothing) -#ifdef DEBUG-import Test.HUnit (Test)-#endif- data Compiler = Compiler {- compilerFlavor :: CompilerFlavor,- compilerId :: PackageIdentifier,- compilerExtensions :: [(Extension, Flag)]+ compilerId :: CompilerId,+ compilerExtensions :: [(Extension, String)] } deriving (Show, Read) showCompilerId :: Compiler -> String-showCompilerId = showPackageId . compilerId+showCompilerId = display . compilerId +compilerFlavor :: Compiler -> CompilerFlavor+compilerFlavor = (\(CompilerId f _) -> f) . compilerId+ compilerVersion :: Compiler -> Version-compilerVersion = pkgVersion . compilerId+compilerVersion = (\(CompilerId _ v) -> v) . compilerId -- ------------------------------------------------------------ -- * Package databases@@ -96,13 +94,37 @@ data PackageDB = GlobalPackageDB | UserPackageDB | SpecificPackageDB FilePath- deriving (Show, Read)+ deriving (Eq, Show, Read) -- ------------------------------------------------------------+-- * Optimisation levels+-- ------------------------------------------------------------++-- | Some compilers support optimising. Some have different levels.+-- For compliers that do not the level is just capped to the level+-- they do support.+--+data OptimisationLevel = NoOptimisation+ | NormalOptimisation+ | MaximumOptimisation+ deriving (Eq, Show, Read, Enum, Bounded)++flagToOptimisationLevel :: Maybe String -> OptimisationLevel+flagToOptimisationLevel Nothing = NormalOptimisation+flagToOptimisationLevel (Just s) = case reads s of+ [(i, "")]+ | i >= fromEnum (minBound :: OptimisationLevel)+ && i <= fromEnum (maxBound :: OptimisationLevel)+ -> toEnum i+ | otherwise -> error $ "Bad optimisation level: " ++ show i+ ++ ". Valid values are 0..2"+ _ -> error $ "Can't parse optimisation level " ++ s++-- ------------------------------------------------------------ -- * Extensions -- ------------------------------------------------------------ --- |For the given compiler, return the flags for the supported extensions.+-- |For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts = [ ext | ext <- exts@@ -116,12 +138,3 @@ nub $ filter (not . null) $ catMaybes [ lookup ext (compilerExtensions comp) | ext <- exts ]---- --------------------------------------------------------------- * Testing--- --------------------------------------------------------------#ifdef DEBUG-hunitTests :: [Test]-hunitTests = []-#endif
Distribution/Simple/Configure.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Configure@@ -51,56 +50,56 @@ getInstalledPackages, configDependency, configCompiler, configCompilerAux,-#ifdef DEBUG- hunitTests-#endif+ ccLdOptionsBuildInfo,+ tryGetConfigStateFile, ) where -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604-#if __GLASGOW_HASKELL__ < 603-#include "config.h"-#else-#include "ghcconfig.h"-#endif-#endif--import Distribution.Compat.Directory- ( createDirectoryIfMissing ) import Distribution.Simple.Compiler- ( CompilerFlavor(..), Compiler(..), compilerVersion, showCompilerId- , unsupportedExtensions, PackageDB(..) )+ ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion+ , showCompilerId, unsupportedExtensions, PackageDB(..) ) import Distribution.Package- ( PackageIdentifier(..), showPackageId )-import Distribution.PackageDescription+ ( PackageIdentifier(PackageIdentifier), packageVersion, Package(..)+ , Dependency(Dependency) )+import Distribution.InstalledPackageInfo+ ( InstalledPackageInfo, emptyInstalledPackageInfo )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+ ( InstalledPackageInfo_(package,depends) )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.PackageDescription as PD ( PackageDescription(..), GenericPackageDescription(..)- , Library(..), Executable(..), BuildInfo(..), finalizePackageDescription- , HookedBuildInfo, sanityCheckPackage, updatePackageDescription- , setupMessage, satisfyDependency, hasLibs, allBuildInfo )-import Distribution.ParseUtils- ( showDependency )+ , Library(..), hasLibs, Executable(..), BuildInfo(..)+ , HookedBuildInfo, updatePackageDescription, allBuildInfo+ , FlagName(..) )+import Distribution.PackageDescription.Configuration+ ( finalizePackageDescription )+import Distribution.PackageDescription.Check+ ( PackageCheck(..)+ , checkPackage, checkConfiguredPackage, checkPackageFiles ) import Distribution.Simple.Program ( Program(..), ProgramLocation(..), ConfiguredProgram(..)- , ProgramConfiguration, configureAllKnownPrograms, knownPrograms+ , ProgramConfiguration, defaultProgramConfiguration+ , configureAllKnownPrograms, knownPrograms+ , userSpecifyArgs, userSpecifyPath , lookupKnownProgram, requireProgram, pkgConfigProgram , rawSystemProgramStdoutConf ) import Distribution.Simple.Setup- ( ConfigFlags(..), CopyDest(..) )+ ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.InstallDirs- ( InstallDirs(..), InstallDirTemplates(..), defaultInstallDirs- , toPathTemplate )+ ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(..), distPref, absoluteInstallDirs+ ( LocalBuildInfo(..), absoluteInstallDirs , prefixRelativeInstallDirs ) import Distribution.Simple.Utils- ( die, warn, info, createDirectoryIfMissingVerbose )+ ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose+ , intercalate, comparing, cabalVersion, cabalBootstrapping ) import Distribution.Simple.Register ( removeInstalledConfig ) import Distribution.System- ( os, OS(..), Windows(..) )+ ( OS(..), buildOS, buildArch ) import Distribution.Version- ( Version(..), Dependency(..), VersionRange(..), showVersion, readVersion- , showVersionRange, orLaterVersion, withinRange )+ ( Version(..), VersionRange(..), orLaterVersion, withinRange ) import Distribution.Verbosity ( Verbosity, lessVerbose ) @@ -113,87 +112,143 @@ ( when, unless, foldM ) import Control.Exception as Exception ( catch )-import Data.Char- ( toLower ) import Data.List- ( intersperse, nub, partition, isPrefixOf )+ ( nub, partition, isPrefixOf, maximumBy ) import Data.Maybe ( fromMaybe, isNothing )+import Data.Monoid+ ( Monoid(..) ) import System.Directory- ( doesFileExist, getModificationTime )-import System.Environment- ( getProgName )+ ( doesFileExist, getModificationTime, createDirectoryIfMissing ) import System.Exit ( ExitCode(..), exitWith ) import System.FilePath- ( (</>) )+ ( (</>), isAbsolute ) import qualified System.Info- ( os, arch )+ ( compilerName, compilerVersion ) import System.IO ( hPutStrLn, stderr, hGetContents, openFile, hClose, IOMode(ReadMode) )+import Distribution.Text+ ( Text(disp), display, simpleParse ) import Text.PrettyPrint.HughesPJ ( comma, punctuate, render, nest, sep ) import Prelude hiding (catch) -#ifdef DEBUG-import Test.HUnit-#endif- tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) tryGetConfigStateFile filename = do- e <- doesFileExist filename- let dieMsg = "error reading " ++ filename ++ - "; run \"setup configure\" command?\n"- if (not e) then return $ Left dieMsg else do - str <- readFileStrict filename- case reads str of- [(bi,_)] -> return $ Right bi- _ -> return $ Left dieMsg+ exists <- doesFileExist filename+ if not exists+ then return (Left missing)+ else do+ str <- readFileStrict filename+ return $ case lines str of+ [headder, rest] -> case checkHeader headder of+ Just msg -> Left msg+ Nothing -> case reads rest of+ [(bi,_)] -> Right bi+ _ -> Left cantParse+ _ -> Left cantParse where- readFileStrict name = do+ readFileStrict name = do h <- openFile name ReadMode- str <- hGetContents h >>= \str -> length str `seq` return str+ 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)+ | cabalId+ == currentCabalId -> Nothing+ | otherwise -> Just (badVersion cabalId compId)+ Nothing -> Just cantParse + missing = "Run the 'configure' command first."+ cantParse = "Saved package config file seems to be corrupt. "+ ++ "Try re-running the 'configure' command."+ badVersion cabalId compId+ = "You need to re-run the 'configure' command. "+ ++ "The version of Cabal being used has changed (was "+ ++ display cabalId ++ ", now "+ ++ display currentCabalId ++ ")."+ ++ badcompiler compId+ badcompiler compId | compId == currentCompilerId = ""+ | otherwise+ = " Additionally the compiler is different (was "+ ++ display compId ++ ", now "+ ++ display currentCompilerId+ ++ ") which is probably the cause of the problem."+ -- internal function-tryGetPersistBuildConfig :: IO (Either String LocalBuildInfo)-tryGetPersistBuildConfig = tryGetConfigStateFile localBuildInfoFile+tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)+tryGetPersistBuildConfig distPref+ = tryGetConfigStateFile (localBuildInfoFile distPref) -- |Read the 'localBuildInfoFile'. Error if it doesn't exist. Also -- fail if the file containing LocalBuildInfo is older than the .cabal -- file, indicating that a re-configure is required.-getPersistBuildConfig :: IO LocalBuildInfo-getPersistBuildConfig = do- lbi <- tryGetPersistBuildConfig+getPersistBuildConfig :: FilePath -> IO LocalBuildInfo+getPersistBuildConfig distPref = do+ lbi <- tryGetPersistBuildConfig distPref either die return lbi -- |Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig = do- lbi <- tryGetPersistBuildConfig+maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)+maybeGetPersistBuildConfig distPref = do+ lbi <- tryGetPersistBuildConfig distPref return $ either (const Nothing) Just lbi -- |After running configure, output the 'LocalBuildInfo' to the -- 'localBuildInfoFile'.-writePersistBuildConfig :: LocalBuildInfo -> IO ()-writePersistBuildConfig lbi = do+writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()+writePersistBuildConfig distPref lbi = do createDirectoryIfMissing False distPref- writeFile localBuildInfoFile (show lbi)+ writeFile (localBuildInfoFile distPref)+ (showHeader pkgid ++ '\n' : show lbi)+ where+ pkgid = packageId (localPkgDescr lbi) +showHeader :: PackageIdentifier -> String+showHeader pkgid =+ "Saved package config for " ++ display pkgid+ ++ " written by " ++ display currentCabalId+ ++ " using " ++ display currentCompilerId+ where++currentCabalId :: PackageIdentifier+currentCabalId = PackageIdentifier "Cabal" currentVersion+ where currentVersion | cabalBootstrapping = Version [0] []+ | otherwise = cabalVersion++currentCompilerId :: PackageIdentifier+currentCompilerId = PackageIdentifier System.Info.compilerName+ System.Info.compilerVersion++parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) +parseHeader header = case words header of+ ["Saved", "package", "config", "for", pkgid,+ "written", "by", cabalid, "using", compilerid]+ -> case (simpleParse pkgid :: Maybe PackageIdentifier,+ simpleParse cabalid,+ simpleParse compilerid) of+ (Just _,+ Just cabalid',+ Just compilerid') -> Just (cabalid', compilerid')+ _ -> Nothing+ _ -> Nothing+ -- |Check that localBuildInfoFile is up-to-date with respect to the -- .cabal file.-checkPersistBuildConfig :: FilePath -> IO ()-checkPersistBuildConfig pkg_descr_file = do+checkPersistBuildConfig :: FilePath -> FilePath -> IO ()+checkPersistBuildConfig distPref pkg_descr_file = do t0 <- getModificationTime pkg_descr_file- t1 <- getModificationTime localBuildInfoFile+ t1 <- getModificationTime $ localBuildInfoFile distPref when (t0 > t1) $ die (pkg_descr_file ++ " has been changed, please re-configure.") -- |@dist\/setup-config@-localBuildInfoFile :: FilePath-localBuildInfoFile = distPref </> "setup-config"+localBuildInfoFile :: FilePath -> FilePath+localBuildInfoFile distPref = distPref </> "setup-config" -- ----------------------------------------------------------------------------- -- * Configuration@@ -205,96 +260,139 @@ , HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo configure (pkg_descr0, pbi) cfg- = do let verbosity = configVerbose cfg- cfg' = cfg { configVerbose = lessVerbose verbosity }+ = do let distPref = fromFlag (configDistPref cfg)+ verbosity = fromFlag (configVerbosity cfg) setupMessage verbosity "Configuring"- (either packageDescription id pkg_descr0)+ (packageId (either packageDescription id pkg_descr0)) createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref + let programsConfig = + flip (foldr (uncurry userSpecifyArgs)) (configProgramArgs cfg)+ . flip (foldr (uncurry userSpecifyPath)) (configProgramPaths cfg)+ $ configPrograms cfg+ userInstall = fromFlag (configUserInstall cfg)+ defaultPackageDB | userInstall = UserPackageDB+ | otherwise = GlobalPackageDB+ packageDb = fromFlagOrDefault defaultPackageDB+ (configPackageDB cfg)+ -- detect compiler- (comp, programsConfig) <- configCompilerAux cfg'+ (comp, programsConfig') <- configCompiler+ (flagToMaybe $ configHcFlavor cfg)+ (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg)+ programsConfig (lessVerbose verbosity) let version = compilerVersion comp flavor = compilerFlavor comp -- FIXME: currently only GHC has hc-pkg- mipkgs <- getInstalledPackages (lessVerbose verbosity) comp- (configPackageDB cfg) programsConfig+ maybePackageIndex <- getInstalledPackages (lessVerbose verbosity) comp+ packageDb programsConfig' - (pkg_descr, flags) <- case pkg_descr0 of+ (pkg_descr0', flags) <- case pkg_descr0 of Left ppd -> case finalizePackageDescription (configConfigurationsFlags cfg)- mipkgs- System.Info.os- System.Info.arch- (map toLower (show flavor),version)+ maybePackageIndex+ Distribution.System.buildOS+ Distribution.System.buildArch+ (compilerId comp)+ (configConstraints cfg) ppd of Right r -> return r Left missing -> die $ "At least the following dependencies are missing:\n" ++ (render . nest 4 . sep . punctuate comma $ - map showDependency missing)+ 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' when (not (null flags)) $- info verbosity $ "Flags chosen: " ++ (concat . intersperse ", " .- map (\(n,b) -> n ++ "=" ++ show b) $ flags)-- (warns, ers) <- sanityCheckPackage $- updatePackageDescription pbi pkg_descr- - errorOut verbosity warns ers+ info verbosity $ "Flags chosen: "+ ++ intercalate ", " [ name ++ "=" ++ display value+ | (FlagName name, value) <- flags ] - let ipkgs = fromMaybe (map setDepByVersion (buildDepends pkg_descr)) mipkgs + checkPackageProblems verbosity+ (either Just (\_->Nothing) pkg_descr0) --TODO: make the Either go away+ (updatePackageDescription pbi pkg_descr) + let packageIndex = fromMaybe bogusPackageIndex maybePackageIndex+ -- 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+ -- based on what other package the package we're currently building+ -- happens to depend on. See 'inventBogusPackageId' below.+ -- Let's hope they really are installed... :-)+ bogusDependencies = map inventBogusPackageId (buildDepends pkg_descr)+ bogusPackageIndex = PackageIndex.fromList+ [ emptyInstalledPackageInfo {+ InstalledPackageInfo.package = bogusPackageId+ -- note that these bogus packages have no other dependencies+ }+ | bogusPackageId <- bogusDependencies ] dep_pkgs <- case flavor of- GHC | version >= Version [6,3] [] -> do- mapM (configDependency verbosity ipkgs) (buildDepends pkg_descr)- JHC -> do- mapM (configDependency verbosity ipkgs) (buildDepends pkg_descr)- _ -> do- return $ map setDepByVersion (buildDepends pkg_descr)+ GHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr)+ JHC -> mapM (configDependency verbosity packageIndex) (buildDepends pkg_descr)+ _ -> return bogusDependencies + packageDependsIndex <-+ case PackageIndex.dependencyClosure packageIndex dep_pkgs of+ Left packageDependsIndex -> return packageDependsIndex+ Right broken ->+ die $ "The following installed packages are broken because other"+ ++ " packages they depend on are missing. These broken "+ ++ "packages must be rebuilt before they can be used.\n"+ ++ unlines [ "package "+ ++ display (packageId pkg)+ ++ " is broken due to missing package "+ ++ intercalate ", " (map display deps)+ | (pkg, deps) <- broken ] - removeInstalledConfig+ let pseudoTopPkg = emptyInstalledPackageInfo {+ InstalledPackageInfo.package = packageId pkg_descr,+ InstalledPackageInfo.depends = dep_pkgs+ }+ case PackageIndex.dependencyInconsistencies+ . PackageIndex.insert pseudoTopPkg+ $ packageDependsIndex of+ [] -> return ()+ inconsistencies ->+ warn verbosity $+ "This package indirectly depends on multiple versions of the same "+ ++ "package. This is highly likely to cause a compile failure.\n"+ ++ unlines [ "package " ++ display pkg ++ " requires "+ ++ display (PackageIdentifier name ver)+ | (name, uses) <- inconsistencies+ , (pkg, ver) <- uses ] + removeInstalledConfig distPref+ -- installation directories- defaultDirs <- defaultInstallDirs flavor (hasLibs pkg_descr)- let maybeDefault confField dirField =- maybe (dirField defaultDirs) toPathTemplate (confField cfg)- installDirs = defaultDirs {- prefixDirTemplate = maybeDefault configPrefix prefixDirTemplate,- binDirTemplate = maybeDefault configBinDir binDirTemplate,- libDirTemplate = maybeDefault configLibDir libDirTemplate,- libSubdirTemplate = maybeDefault configLibSubDir libSubdirTemplate,- libexecDirTemplate = maybeDefault configLibExecDir libexecDirTemplate,- dataDirTemplate = maybeDefault configDataDir dataDirTemplate,- dataSubdirTemplate = maybeDefault configDataSubDir dataSubdirTemplate,- docDirTemplate = maybeDefault configDocDir docDirTemplate,- htmlDirTemplate = maybeDefault configHtmlDir htmlDirTemplate,- interfaceDirTemplate = maybeDefault configInterfaceDir interfaceDirTemplate- }+ defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)+ let installDirs = combineInstallDirs fromFlagOrDefault+ defaultDirs (configInstallDirs cfg) -- check extensions let extlist = nub $ concatMap extensions (allBuildInfo pkg_descr) let exts = unsupportedExtensions comp extlist unless (null exts) $ warn verbosity $ -- Just warn, FIXME: Should this be an error?- show flavor ++ " does not support the following extensions:\n " ++- concat (intersperse ", " (map show exts))+ display flavor ++ " does not support the following extensions: " +++ intercalate ", " (map display exts) let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr)- programsConfig' <-- configureAllKnownPrograms (lessVerbose verbosity) programsConfig+ programsConfig'' <-+ configureAllKnownPrograms (lessVerbose verbosity) programsConfig' >>= configureRequiredPrograms verbosity requiredBuildTools - (pkg_descr', programsConfig'') <- configurePkgconfigPackages verbosity- pkg_descr programsConfig'+ (pkg_descr', programsConfig''') <- configurePkgconfigPackages verbosity+ pkg_descr programsConfig'' split_objs <- - if not (configSplitObjs cfg)+ if not (fromFlag $ configSplitObjs cfg) then return False else case flavor of GHC | version >= Version [6,5] [] -> return True@@ -307,34 +405,45 @@ installDirTemplates = installDirs, compiler = comp, buildDir = distPref </> "build",- scratchDir = distPref </> "scratch",+ scratchDir = fromFlagOrDefault+ (distPref </> "scratch")+ (configScratchDir cfg), packageDeps = dep_pkgs,+ installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, localPkgDescr = pkg_descr',- withPrograms = programsConfig'',- withVanillaLib = configVanillaLib cfg,- withProfLib = configProfLib cfg,- withSharedLib = configSharedLib cfg,- withProfExe = configProfExe cfg,- withOptimization = configOptimization cfg,- withGHCiLib = configGHCiLib cfg,+ 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,- withPackageDB = configPackageDB cfg+ stripExes = fromFlag $ configStripExes cfg,+ withPackageDB = packageDb,+ progPrefix = fromFlag $ configProgPrefix cfg,+ progSuffix = fromFlag $ configProgSuffix cfg } let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest relative = prefixRelativeInstallDirs pkg_descr lbi + unless (isAbsolute (prefix dirs)) $ die $+ "expected an absolute directory name for --prefix: " ++ prefix dirs++ info verbosity $ "Using " ++ display currentCabalId+ ++ " compiled by " ++ display currentCompilerId info verbosity $ "Using compiler: " ++ showCompilerId comp info verbosity $ "Using install prefix: " ++ prefix dirs let dirinfo name dir isPrefixRelative = info verbosity $ name ++ " installed in: " ++ dir ++ relNote- where relNote = case os of- Windows MingW | not (hasLibs pkg_descr)- && isNothing isPrefixRelative- -> " (fixed location)"- _ -> ""+ where relNote = case buildOS of+ Windows | not (hasLibs pkg_descr)+ && isNothing isPrefixRelative+ -> " (fixed location)"+ _ -> "" dirinfo "Binaries" (bindir dirs) (bindir relative) dirinfo "Libraries" (libdir dirs) (libdir relative)@@ -343,23 +452,30 @@ dirinfo "Documentation" (docdir dirs) (docdir relative) sequence_ [ reportProgram verbosity prog configuredProg- | (prog, configuredProg) <- knownPrograms programsConfig' ]+ | (prog, configuredProg) <- knownPrograms programsConfig''' ] return lbi -+ where+ addExtraIncludeLibDirs pkg_descr =+ let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg+ , PD.includeDirs = configExtraIncludeDirs cfg}+ modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi }+ modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi}+ in pkg_descr{ library = modifyLib `fmap` library pkg_descr+ , executables = modifyExecutable `map` executables pkg_descr} -- ----------------------------------------------------------------------------- -- Configuring package dependencies -- |Converts build dependencies to a versioned dependency. only sets -- version information for exact versioned dependencies.-setDepByVersion :: Dependency -> PackageIdentifier+inventBogusPackageId :: Dependency -> PackageIdentifier -- if they specify the exact version, use that:-setDepByVersion (Dependency s (ThisVersion v)) = PackageIdentifier s v+inventBogusPackageId (Dependency s (ThisVersion v)) = PackageIdentifier s v -- otherwise, just set it to empty-setDepByVersion (Dependency s _) = PackageIdentifier s (Version [] [])+inventBogusPackageId (Dependency s _) = PackageIdentifier s (Version [] []) reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () reportProgram verbosity prog Nothing@@ -371,31 +487,31 @@ UserSpecified p -> " given by user at: " ++ p version = case programVersion configuredProg of Nothing -> ""- Just v -> " version " ++ showVersion v+ Just v -> " version " ++ display v hackageUrl :: String hackageUrl = "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/" -- | Test for a package dependency and record the version we have installed.-configDependency :: Verbosity -> [PackageIdentifier] -> Dependency -> IO PackageIdentifier-configDependency verbosity ps dep@(Dependency pkgname vrange) =- case satisfyDependency ps dep of- Nothing -> die $ "cannot satisfy dependency "- ++ pkgname ++ showVersionRange vrange ++ "\n"+configDependency :: Verbosity -> PackageIndex InstalledPackageInfo -> Dependency -> IO PackageIdentifier+configDependency verbosity index dep@(Dependency pkgname vrange) =+ case PackageIndex.lookupDependency index dep of+ [] -> die $ "cannot satisfy dependency "+ ++ pkgname ++ display vrange ++ "\n" ++ "Perhaps you need to download and install it from\n" ++ hackageUrl ++ pkgname ++ "?"- Just pkg -> do info verbosity $ "Dependency " ++ pkgname- ++ showVersionRange vrange- ++ ": using " ++ showPackageId pkg- return pkg+ pkgs -> do let pkgid = maximumBy (comparing packageVersion) (map packageId pkgs)+ info verbosity $ "Dependency " ++ pkgname+ ++ display vrange+ ++ ": using " ++ display pkgid+ return pkgid getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration- -> IO (Maybe [PackageIdentifier])+ -> IO (Maybe (PackageIndex InstalledPackageInfo)) getInstalledPackages verbosity comp packageDb progconf = do info verbosity "Reading installed packages..." case compilerFlavor comp of- GHC | compilerVersion comp >= Version [6,3] []- -> Just `fmap` GHC.getInstalledPackages verbosity packageDb progconf+ GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDb progconf JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDb progconf _ -> return Nothing @@ -437,7 +553,7 @@ requirePkg (Dependency pkg range) = do version <- pkgconfig ["--modversion", pkg] `Exception.catch` \_ -> die notFound- case readVersion version of+ 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)@@ -446,52 +562,62 @@ ++ " 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 " ++ showVersion v- depSatisfied v = "Dependency " ++ pkg ++ showVersionRange range- ++ ": using version " ++ showVersion v+ ++ " system is version " ++ display v+ depSatisfied v = "Dependency " ++ pkg ++ display range+ ++ ": using version " ++ display v versionRequirement | range == AnyVersion = ""- | otherwise = " version " ++ showVersionRange range + | otherwise = " version " ++ display range updateLibrary Nothing = return Nothing updateLibrary (Just lib) = do- let bi = libBuildInfo lib- bi' <- updateBuildInfo bi- return $ Just lib { libBuildInfo = bi' }+ bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib))+ return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi } updateExecutable exe = do- let bi = buildInfo exe- bi' <- updateBuildInfo bi- return exe { buildInfo = bi' }+ bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe))+ return exe { buildInfo = buildInfo exe `mappend` bi } - updateBuildInfo :: BuildInfo -> IO BuildInfo- updateBuildInfo bi- | not (buildable bi) = return bi- | otherwise = do- let pkgs = nub [ pkg | Dependency pkg _ <- pkgconfigDepends bi ]- cflags <- words `fmap` pkgconfig ("--cflags" : pkgs)- ldflags <- words `fmap` pkgconfig ("--libs" : pkgs)- let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags- (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags- (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'- return bi {- includeDirs = includeDirs bi ++ map (drop 2) includeDirs',- extraLibs = extraLibs bi ++ map (drop 2) extraLibs',- extraLibDirs = extraLibDirs bi ++ map (drop 2) extraLibDirs',- ccOptions = ccOptions bi ++ cflags',- ldOptions = ldOptions bi ++ ldflags''- }+ pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo+ pkgconfigBuildInfo pkgdeps = do+ let pkgs = nub [ pkg | Dependency pkg _ <- pkgdeps ]+ ccflags <- pkgconfig ("--cflags" : pkgs)+ ldflags <- pkgconfig ("--libs" : pkgs)+ return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) +-- | Makes a 'BuildInfo' from C compiler and linker flags.+--+-- This can be used with the output from configuration programs like pkg-config+-- and similar package-specific programs like mysql-config, freealut-config etc.+-- For example:+--+-- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"]+-- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"]+-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags))+--+ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo+ccLdOptionsBuildInfo cflags ldflags =+ let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags+ (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags+ (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'+ in mempty {+ PD.includeDirs = map (drop 2) includeDirs',+ PD.extraLibs = map (drop 2) extraLibs',+ PD.extraLibDirs = map (drop 2) extraLibDirs',+ PD.ccOptions = cflags',+ PD.ldOptions = ldflags''+ }+ -- ----------------------------------------------------------------------------- -- Determining the compiler details configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration)-configCompilerAux cfg = configCompiler (configHcFlavor cfg)- (configHcPath cfg)- (configHcPkg cfg)- (configPrograms cfg)- (configVerbose cfg)+configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg)+ (flagToMaybe $ configHcPath cfg)+ (flagToMaybe $ configHcPkg cfg)+ defaultProgramConfiguration+ (fromFlag (configVerbosity cfg)) configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> Verbosity@@ -506,27 +632,29 @@ _ -> die "Unknown compiler" --- |Output warnings and errors. Exit if any errors.-errorOut :: Verbosity -- ^Verbosity- -> [String] -- ^Warnings- -> [String] -- ^errors- -> IO ()-errorOut verbosity warnings errors = do- mapM_ (warn verbosity) warnings- when (not (null errors)) $ do- pname <- getProgName- mapM (hPutStrLn stderr . ((pname ++ ": Error: ") ++)) errors- exitWith (ExitFailure 1)-+-- | Output package check warnings and errors. Exit if any errors.+checkPackageProblems :: Verbosity+ -> Maybe GenericPackageDescription+ -> PackageDescription+ -> IO ()+checkPackageProblems verbosity mgpkg pkg = do+ ioChecks <- checkPackageFiles pkg "."+ let pureChecks = case mgpkg of+ Just gpkg -> checkPackage gpkg (Just pkg)+ Nothing -> checkConfiguredPackage pkg+ errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]+ warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ]+ if null errors+ then mapM_ (warn verbosity) warnings+ else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors+ exitWith (ExitFailure 1) -- ----------------------------------------------------------------------------- -- Tests -#ifdef DEBUG-+{- Too specific: hunitTests :: [Test] hunitTests = []-{- Too specific: packageID = PackageIdentifier "Foo" (Version [1] []) = [TestCase $ do let simonMarGHCLoc = "/usr/bin/ghc"@@ -541,4 +669,3 @@ simonMarGHC ] -}-#endif
Distribution/Simple/GHC.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC@@ -45,60 +44,62 @@ module Distribution.Simple.GHC ( configure, getInstalledPackages, build, makefile, installLib, installExe,+ ghcOptions, ghcVerbosityOptions ) where import Distribution.Simple.GHC.Makefile-import Distribution.Simple.Setup ( MakefileFlags(..) )+import Distribution.Simple.Setup ( MakefileFlags(..),+ fromFlag, fromFlagOrDefault) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..),- withLib, setupMessage,+ withLib, Executable(..), withExe, Library(..), libModules, hcOptions )+import Distribution.InstalledPackageInfo+ ( InstalledPackageInfo+ , parseInstalledPackageInfo )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(..), autogenModulesDir )+ ( LocalBuildInfo(..) )+import Distribution.Simple.BuildPaths import Distribution.Simple.Utils-import Distribution.Package ( PackageIdentifier(..), showPackageId,- parsePackageId )-import Distribution.Simple.Program ( rawSystemProgram, rawSystemProgramConf,- rawSystemProgramStdoutConf,- rawSystemProgramStdout,- Program(..), ConfiguredProgram(..),- ProgramConfiguration,- userMaybeSpecifyPath, requireProgram,- programPath, lookupProgram, updateProgram,- ghcProgram, ghcPkgProgram,- arProgram, ranlibProgram, ldProgram )+import Distribution.Package+ ( PackageIdentifier, Package(..) )+import Distribution.Simple.Program+ ( Program(..), ConfiguredProgram(..), ProgramConfiguration+ , rawSystemProgram, rawSystemProgramConf+ , rawSystemProgramStdout, rawSystemProgramStdoutConf, requireProgram+ , userMaybeSpecifyPath, programPath, lookupProgram, updateProgram+ , ghcProgram, ghcPkgProgram, arProgram, ranlibProgram, ldProgram+ , stripProgram ) import Distribution.Simple.Compiler-import Distribution.Version ( Version(..), showVersion,- VersionRange(..), orLaterVersion )-import qualified Distribution.Simple.GHC.PackageConfig as GHC- ( localPackageConfig,- canReadLocalPackageConfig )+ ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion+ , OptimisationLevel(..), PackageDB(..), Flag, extensionsToFlags )+import Distribution.Version+ ( Version(..), VersionRange(..), orLaterVersion ) import Distribution.System+ ( OS(..), buildOS ) import Distribution.Verbosity+import Distribution.Text+ ( display, simpleParse ) import Language.Haskell.Extension (Extension(..))-import Distribution.Compat.ReadP- ( readP_to_S, many, skipSpaces ) import Control.Monad ( unless, when ) import Data.Char-import Data.List ( nub, isPrefixOf )+import Data.List ( nub )+import Data.Maybe ( catMaybes )+import Data.Monoid ( Monoid(mconcat) ) import System.Directory ( removeFile, renameFile,- getDirectoryContents, doesFileExist )-import Distribution.Compat.Directory ( getTemporaryDirectory )-import Distribution.Compat.TempFile ( withTempFile )+ getDirectoryContents, doesFileExist,+ getTemporaryDirectory ) import System.FilePath ( (</>), (<.>), takeExtension, takeDirectory, replaceExtension, splitExtension )-import System.IO-import Control.Exception as Exception (handle)---- System.IO used to export a different try, so we can't use try unqualified-#ifndef __NHC__-import Control.Exception as Try-#else-import IO as Try-#endif+import System.IO (openFile, IOMode(WriteMode), hClose, hPutStrLn)+import Control.Exception as Exception+ ( catch, handle, try ) -- ----------------------------------------------------------------------------- -- Configuring@@ -108,7 +109,7 @@ configure verbosity hcPath hcPkgPath conf = do (ghcProg, conf') <- requireProgram verbosity ghcProgram - (orLaterVersion (Version [6,2] []))+ (orLaterVersion (Version [6,4] [])) (userMaybeSpecifyPath "ghc" hcPath conf) let Just ghcVersion = programVersion ghcProg @@ -123,13 +124,13 @@ let Just ghcPkgVersion = programVersion ghcPkgProg when (ghcVersion /= ghcPkgVersion) $ die $- "Version mismatch between ghc and ghc-pkg:\n"- ++ programPath ghcProg ++ " is version " ++ showVersion ghcVersion ++ "\n"- ++ programPath ghcPkgProg ++ " is version " ++ showVersion ghcPkgVersion+ "Version mismatch between ghc and ghc-pkg: "+ ++ 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 os of- Windows _ ->+ let ldProgram' = case buildOS of+ Windows -> let compilerDir = takeDirectory (programPath ghcProg) baseDir = takeDirectory compilerDir binInstallLd = baseDir </> "gcc-lib" </> "ld.exe"@@ -141,13 +142,15 @@ -- 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 ->- withTempFile tempDir "o" $ \testofile -> do- writeFile testcfile "int foo() {}\n"+ 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' ->- Exception.handle (\_ -> return False) $ do+ withTempFile tempDir ".o" $ \testofile' testohnd' ->+ handle (\_ -> return False) $ do+ hClose testohnd' rawSystemProgramStdout verbosity ldProg ["-x", "-r", testofile, "-o", testofile'] return True@@ -158,19 +161,23 @@ -- configuration needs to be in a state monad. That is exactly the plan -- (along with some other stuff to give Cabal a better DSL). - let isSep c = isSpace c || (c == ',') languageExtensions <- if ghcVersion >= Version [6,7] [] then do exts <- rawSystemStdout verbosity (programPath ghcProg) ["--supported-languages"]- return [ (ext, "-X" ++ show ext)- | extStr <- breaks isSep exts- , (ext, "") <- reads extStr ++ reads ("No" ++ extStr) ]+ -- GHC has the annoying habit of inverting some of the extensions+ -- so we have to try parsing ("No" ++ ghcExtensionName) first+ let readExtension str = do+ ext <- simpleParse ("No" ++ str)+ case ext of+ UnknownExtension _ -> simpleParse str+ _ -> return ext+ return [ (ext, "-X" ++ display ext)+ | Just ext <- map readExtension (lines exts) ] else return oldLanguageExtensions let comp = Compiler {- compilerFlavor = GHC,- compilerId = PackageIdentifier "ghc" ghcVersion,+ compilerId = CompilerId GHC ghcVersion, compilerExtensions = languageExtensions } return (comp, conf'''')@@ -256,33 +263,72 @@ fglasgowExts = "-fglasgow-exts" getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration- -> IO [PackageIdentifier]+ -> IO (PackageIndex InstalledPackageInfo) getInstalledPackages verbosity packagedb conf = do- --TODO: use --simple-output flag for easier parsing- str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf- [packageDbGhcPkgFlag packagedb, "list"]- let str1 = case packagedb of- UserPackageDB -> allFiles str- _ -> firstFile str- str2 = filter (`notElem` ",(){}") str1- --- case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str2) of- [ps] -> return ps- _ -> die "cannot parse package list"+ let packagedbs = case packagedb of+ GlobalPackageDB -> [GlobalPackageDB]+ _ -> [GlobalPackageDB, packagedb]+ pkgss <- getInstalledPackages' verbosity packagedbs conf+ return $ mconcat [ PackageIndex.fromList pkgs+ | (_, pkgs) <- pkgss ]++-- | Get the packages from specific PackageDBs, not cumulative.+--+getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration+ -> IO [(PackageDB, [InstalledPackageInfo])]+getInstalledPackages' verbosity packagedbs conf+ | 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."+ case parsePackages str of+ Left ok -> return (packagedb, ok)+ _ -> die "failed to parse output of 'ghc-pkg describe *'"+ | packagedb <- packagedbs ]+ where+ parsePackages str =+ let parsed = map parseInstalledPackageInfo (splitPkgs str)+ in case [ msg | ParseFailed msg <- parsed ] of+ [] -> Left [ pkg | ParseOk _ pkg <- parsed ]+ msgs -> Right msgs++ Just ghcProg = lookupProgram ghcProgram conf+ 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+ packageDbGhcPkgFlag GlobalPackageDB = "--global" packageDbGhcPkgFlag UserPackageDB = "--user" packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path - pCheck :: [(a, [Char])] -> [a]- pCheck rs = [ r | (r,s) <- rs, all isSpace s ]-- allFiles str = unlines $ filter keep_line $ lines str- where keep_line s = ':' `notElem` s && not ("Creating" `isPrefixOf` s)-- firstFile str = unlines $ takeWhile (not . file_line) $- drop 1 $ dropWhile (not . file_line) $ lines str- where file_line s = ':' `elem` s && not ("Creating" `isPrefixOf` s)+getInstalledPackages' verbosity packagedbs conf = do+ str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]+ let pkgFiles = [ init line | line <- lines str, last line == ':' ]+ dbFile packagedb = case (packagedb, pkgFiles) of+ (GlobalPackageDB, global:_) -> return $ Just global+ (UserPackageDB, _global:user:_) -> return $ Just user+ (UserPackageDB, _global:_) -> return $ Nothing+ (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+ | (db , Just file) <- zip packagedbs pkgFiles' ] -- ----------------------------------------------------------------------------- -- Building@@ -292,22 +338,13 @@ build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () build pkg_descr lbi verbosity = do let pref = buildDir lbi+ pkgid = packageId pkg_descr runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) ifProfLib = when (withProfLib lbi) ifSharedLib = when (withSharedLib lbi) ifGHCiLib = when (withGHCiLib lbi) - -- GHC versions prior to 6.4 didn't have the user package database,- -- so we fake it. TODO: This can go away in due course.- pkg_conf <- if versionBranch (compilerVersion (compiler lbi)) >= [6,4]- then return []- else do pkgConf <- GHC.localPackageConfig- pkgConfReadable <- GHC.canReadLocalPackageConfig- if pkgConfReadable - then return ["-package-conf", pkgConf]- else return []- -- Build lib withLib pkg_descr () $ \lib -> do info verbosity "Building library..."@@ -317,17 +354,9 @@ -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir- -- put hi-boot files into place for mutually recurive modules- smartCopySources verbosity (hsSourceDirs libBi)- libTargetDir (libModules pkg_descr) ["hi-boot"] False False- let ghc_vers = compilerVersion (compiler lbi)- packageId | versionBranch ghc_vers >= [6,4]- = showPackageId (package pkg_descr)- | otherwise = pkgName (package pkg_descr)- -- Only use the version number with ghc-6.4 and later- ghcArgs =- pkg_conf- ++ ["-package-name", packageId ]+ -- 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) ghcArgsProf = ghcArgs@@ -361,17 +390,24 @@ info verbosity "Linking..." let cObjs = map (`replaceExtension` objExtension) (cSources libBi) cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)- libName = mkLibName pref (showPackageId (package pkg_descr))- profLibName = mkProfLibName pref (showPackageId (package pkg_descr))- sharedLibName = mkSharedLibName pref (showPackageId (package pkg_descr)) (compilerId (compiler lbi))- ghciLibName = mkGHCiLibName pref (showPackageId (package pkg_descr))+ vanillaLibFilePath = libTargetDir </> mkLibName pkgid+ profileLibFilePath = libTargetDir </> mkProfLibName pkgid+ sharedLibFilePath = libTargetDir </> mkSharedLibName pkgid+ (compilerId (compiler lbi))+ ghciLibFilePath = libTargetDir </> mkGHCiLibName pkgid - stubObjs <- sequence [moduleToFilePath [libTargetDir] (x ++"_stub") [objExtension]- | x <- libModules pkg_descr ] >>= return . concat- stubProfObjs <- sequence [moduleToFilePath [libTargetDir] (x ++"_stub") ["p_" ++ objExtension]- | x <- libModules pkg_descr ] >>= return . concat- stubSharedObjs <- sequence [moduleToFilePath [libTargetDir] (x ++"_stub") ["dyn_" ++ objExtension]- | x <- libModules pkg_descr ] >>= return . concat+ stubObjs <- fmap catMaybes $ sequence+ [ findFileWithExtension [objExtension] [libTargetDir]+ (dotToSep x ++"_stub")+ | x <- libModules pkg_descr ]+ stubProfObjs <- fmap catMaybes $ sequence+ [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]+ (dotToSep x ++"_stub")+ | x <- libModules pkg_descr ]+ stubSharedObjs <- fmap catMaybes $ sequence+ [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]+ (dotToSep x ++"_stub")+ | x <- libModules pkg_descr ] hObjs <- getHaskellObjects pkg_descr libBi lbi pref objExtension True@@ -387,28 +423,29 @@ else return [] unless (null hObjs && null cObjs && null stubObjs) $ do- Try.try (removeFile libName) -- first remove library if it exists- Try.try (removeFile profLibName) -- first remove library if it exists- Try.try (removeFile sharedLibName) -- first remove library if it exists- Try.try (removeFile ghciLibName) -- first remove library if it exists+ -- first remove library files if they exists+ sequence_+ [ try (removeFile libFilePath)+ | libFilePath <- [vanillaLibFilePath, profileLibFilePath+ ,sharedLibFilePath, ghciLibFilePath] ] let arVerbosity | verbosity >= deafening = "v" | verbosity >= normal = "" | otherwise = "c" arArgs = ["q"++ arVerbosity]- ++ [libName]+ ++ [vanillaLibFilePath] arObjArgs = hObjs ++ map (pref </>) cObjs ++ stubObjs arProfArgs = ["q"++ arVerbosity]- ++ [profLibName]+ ++ [profileLibFilePath] arProfObjArgs = hProfObjs ++ map (pref </>) cObjs ++ stubProfObjs ldArgs = ["-r"]- ++ ["-o", ghciLibName <.> "tmp"]+ ++ ["-o", ghciLibFilePath <.> "tmp"] ldObjArgs = hObjs ++ map (pref </>) cObjs@@ -423,10 +460,10 @@ ghcSharedLinkArgs = [ "-shared", "-dynamic",- "-o", sharedLibName ]+ "-o", sharedLibFilePath ] ++ ghcSharedObjArgs- ++ ["-package-name", packageId ]- ++ (concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ])+ ++ ["-package-name", display pkgid ]+ ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) ++ ["-l"++extraLib | extraLib <- extraLibs libBi] ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] @@ -442,9 +479,11 @@ runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) - --TODO: discover this at configure time on unix- -- used to be 30k, but Solaris needs 2k (see GHC bug #1785)- maxCommandLineSize = 2048+ --TODO: discover this at configure time or runtime on unix+ -- The value is 32k on Windows and posix specifies a minimum of 4k+ -- but all sensible unixes use more than 4k.+ -- we could use getSysVar ArgumentLimit but that's in the unix lib+ maxCommandLineSize = 30 * 1024 ifVanillaLib False $ xargs maxCommandLineSize runAr arArgs arObjArgs@@ -453,12 +492,13 @@ runAr arProfArgs arProfObjArgs ifGHCiLib $ xargs maxCommandLineSize- (runLd ghciLibName) ldArgs ldObjArgs+ (runLd ghciLibFilePath) ldArgs ldObjArgs ifSharedLib $ runGhcProg ghcSharedLinkArgs -- build any executables- withExe pkg_descr $ \ (Executable exeName' modPath exeBi) -> do+ withExe pkg_descr $ \Executable { exeName = exeName', modulePath = modPath,+ buildInfo = exeBi } -> do info verbosity $ "Building executable: " ++ exeName' ++ "..." -- exeNameReal, the name that GHC really uses (with .exe on Windows)@@ -469,10 +509,8 @@ let exeDir = targetDir </> (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir- -- put hi-boot files into place for mutually recursive modules+ -- TODO: do we need to put hs-boot files into place for mutually recursive modules? -- FIX: what about exeName.hi-boot?- smartCopySources verbosity (hsSourceDirs exeBi)- exeDir (otherModules exeBi) ["hi-boot"] False False -- build executables unless (null (cSources exeBi)) $ do@@ -487,8 +525,7 @@ let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) let binArgs linkExe profExe =- pkg_conf- ++ (if linkExe+ (if linkExe then ["-o", targetDir </> exeNameReal] else ["-c"]) ++ constructGHCCmdLine lbi exeBi exeDir verbosity@@ -555,14 +592,12 @@ ghcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] ghcOptions lbi bi odir- = (if compilerVersion c > Version [6,4] []- then ["-hide-all-packages"]- else [])+ = ["-hide-all-packages"] ++ (if splitObjs lbi then ["-split-objs"] else []) ++ ["-i"]- ++ ["-i" ++ autogenModulesDir lbi] ++ ["-i" ++ odir] ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]+ ++ ["-i" ++ autogenModulesDir lbi] ++ ["-I" ++ odir] ++ ["-I" ++ dir | dir <- includeDirs bi] ++ ["-optP" ++ opt | opt <- cppOptions bi]@@ -571,9 +606,12 @@ ++ [ "-odir", odir, "-hidir", odir ] ++ (if compilerVersion c >= Version [6,8] [] then ["-stubdir", odir] else [])- ++ (concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ])- ++ (if withOptimization lbi then ["-O"] else [])- ++ hcOptions GHC (options bi)+ ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ])+ ++ (case withOptimization lbi of+ NoOptimisation -> []+ NormalOptimisation -> ["-O"]+ MaximumOptimisation -> ["-O2"])+ ++ hcOptions GHC bi ++ extensionsToFlags c (extensions bi) where c = compiler lbi @@ -594,24 +632,23 @@ ghcCcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] ghcCcOptions lbi bi odir = ["-I" ++ dir | dir <- includeDirs bi]- ++ concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ]+ ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] ++ ["-optc" ++ opt | opt <- ccOptions bi]- ++ (if withOptimization lbi then ["-optc-O2"] else [])+ ++ (case withOptimization lbi of+ NoOptimisation -> []+ _ -> ["-optc-O2"]) ++ ["-odir", odir] -mkGHCiLibName :: FilePath -- ^file Prefix- -> String -- ^library name.- -> String-mkGHCiLibName pref lib = pref </> ("HS" ++ lib) <.> ".o"+mkGHCiLibName :: PackageIdentifier -> String+mkGHCiLibName lib = "HS" ++ display lib <.> "o" -- ----------------------------------------------------------------------------- -- Building a Makefile makefile :: PackageDescription -> LocalBuildInfo -> MakefileFlags -> IO () makefile pkg_descr lbi flags = do- let file = case makefileFile flags of- Just f -> f- _otherwise -> "Makefile"+ let file = fromFlagOrDefault "Makefile"(makefileFile flags)+ verbosity = fromFlag (makefileVerbosity flags) targetExists <- doesFileExist file when targetExists $ die ("Not overwriting existing copy of " ++ file)@@ -620,36 +657,33 @@ let Just lib = library pkg_descr bi = libBuildInfo lib - ghc_vers = compilerVersion (compiler lbi)- packageId | versionBranch ghc_vers >= [6,4]- = showPackageId (package pkg_descr)- | otherwise = pkgName (package pkg_descr)- (arProg, _) <- requireProgram (makefileVerbose flags) arProgram AnyVersion+ packageIdStr = display (packageId pkg_descr)+ (arProg, _) <- requireProgram verbosity arProgram AnyVersion (withPrograms lbi)- (ldProg, _) <- requireProgram (makefileVerbose flags) ldProgram AnyVersion+ (ldProg, _) <- requireProgram verbosity ldProgram AnyVersion (withPrograms lbi) let builddir = buildDir lbi Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) let decls = [ ("modules", unwords (exposedModules lib ++ otherModules bi)), ("GHC", programPath ghcProg),- ("GHC_VERSION", (showVersion (compilerVersion (compiler lbi)))),+ ("GHC_VERSION", (display (compilerVersion (compiler lbi)))), ("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", packageId),+ ("package", packageIdStr), ("GHC_OPTS", unwords ( - ["-package-name", packageId ]+ ["-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", mkGHCiLibName builddir (showPackageId (package pkg_descr))),+ ("GHCI_LIB", builddir </> mkGHCiLibName (packageId pkg_descr)), ("soext", dllExtension),- ("LIB_LD_OPTS", unwords (["-package-name", packageId]- ++ concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ]+ ("LIB_LD_OPTS", unwords (["-package-name", packageIdStr]+ ++ concat [ ["-package", display pkg] | pkg <- packageDeps lbi ] ++ ["-l"++libName | libName <- extraLibs bi] ++ ["-L"++libDir | libDir <- extraLibDirs bi])), ("AR", programPath arProg),@@ -671,16 +705,27 @@ -- |Install executables for GHC. installExe :: Verbosity -- ^verbosity+ -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^Build location+ -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> IO ()-installExe verbosity pref buildPref pkg_descr+installExe verbosity lbi pref buildPref (progprefix, progsuffix) pkg_descr = do createDirectoryIfMissingVerbose verbosity True pref- withExe pkg_descr $ \ (Executable e _ _) -> do+ withExe pkg_descr $ \Executable { exeName = e } -> do let exeFileName = e <.> exeExtension- copyFileVerbose verbosity (buildPref </> e </> exeFileName) (pref </> exeFileName)+ fixedExeFileName = (progprefix ++ e ++ progsuffix) <.> exeExtension+ copyFileVerbose verbosity (buildPref </> e </> exeFileName) (pref </> fixedExeFileName)+ stripExe verbosity lbi exeFileName (pref </> fixedExeFileName) +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()+stripExe verbosity lbi name path = when (stripExes lbi) $+ case lookupProgram stripProgram (withPrograms lbi) of+ Just strip -> rawSystemProgram verbosity strip [path]+ Nothing -> warn verbosity $ "Unable to strip executable '" ++ name+ ++ "' (missing the 'strip' program)"+ -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib :: Verbosity -- ^verbosity -> LocalBuildInfo@@ -688,37 +733,51 @@ -> FilePath -- ^install location for dynamic librarys -> FilePath -- ^Build location -> PackageDescription -> IO ()-installLib verbosity lbi pref dynPref buildPref- pd@PackageDescription{library=Just _,- package=p}- = do let programConf = withPrograms lbi- ifVanilla $ smartCopySources verbosity [buildPref] pref (libModules pd) ["hi"] True False- ifProf $ smartCopySources verbosity [buildPref] pref (libModules pd) ["p_hi"] True False- let libTargetLoc = mkLibName pref (showPackageId p)- profLibTargetLoc = mkProfLibName pref (showPackageId p)- libGHCiTargetLoc = mkGHCiLibName pref (showPackageId p)- sharedLibTargetLoc = mkSharedLibName dynPref (showPackageId p) (compilerId (compiler lbi))- ifVanilla $ copyFileVerbose verbosity (mkLibName buildPref (showPackageId p)) libTargetLoc- ifProf $ copyFileVerbose verbosity (mkProfLibName buildPref (showPackageId p)) profLibTargetLoc- ifGHCi $ copyFileVerbose verbosity (mkGHCiLibName buildPref (showPackageId p)) libGHCiTargetLoc- ifShared $ copyFileVerbose verbosity (mkSharedLibName buildPref (showPackageId p) (compilerId (compiler lbi))) sharedLibTargetLoc+installLib verbosity lbi targetDir dynlibTargetDir builtDir+ pkg@PackageDescription{library=Just _} = do+ -- copy .hi files over:+ let copyModuleFiles ext =+ smartCopySources verbosity [builtDir] targetDir (libModules pkg) [ext]+ ifVanilla $ copyModuleFiles "hi"+ ifProf $ copyModuleFiles "p_hi" - -- use ranlib or ar -s to build an index. this is necessary- -- on some systems like MacOS X. If we can't find those,- -- don't worry too much about it.- case lookupProgram ranlibProgram programConf of- Just rl -> do ifVanilla $ rawSystemProgram verbosity rl [libTargetLoc]- ifProf $ rawSystemProgram verbosity rl [profLibTargetLoc]+ -- 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 - Nothing -> case lookupProgram arProgram programConf of- Just ar -> do ifVanilla $ rawSystemProgram verbosity ar ["-s", libTargetLoc]- ifProf $ rawSystemProgram verbosity ar ["-s", profLibTargetLoc]- Nothing -> setupMessage verbosity "Warning: Unable to generate index for library (missing ranlib and ar)" pd- return ()- where ifVanilla action = when (withVanillaLib lbi) (action >> return ())- ifProf action = when (withProfLib lbi) (action >> return ())- ifGHCi action = when (withGHCiLib lbi) (action >> return ())- ifShared action = when (withSharedLib lbi) (action >> return ())+ -- run ranlib if necessary:+ ifVanilla $ updateLibArchive verbosity lbi (targetDir </> vanillaLibName)+ ifProf $ updateLibArchive verbosity lbi (targetDir </> profileLibName) + where+ vanillaLibName = mkLibName pkgid+ profileLibName = mkProfLibName pkgid+ ghciLibName = mkGHCiLibName pkgid+ sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi))++ pkgid = packageId pkg+ copy src dst n = copyFileVerbose verbosity (src </> n) (dst </> n)++ ifVanilla = when (withVanillaLib lbi)+ ifProf = when (withProfLib lbi)+ ifGHCi = when (withGHCiLib lbi)+ ifShared = when (withSharedLib lbi)+ installLib _ _ _ _ _ PackageDescription{library=Nothing} = die $ "Internal Error. installLibGHC called with no library."++-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems+-- like MacOS X. If we can't find those, don't worry too much about it.+--+updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()+updateLibArchive verbosity lbi path =+ case lookupProgram ranlibProgram (withPrograms lbi) of+ Just ranlib -> rawSystemProgram verbosity ranlib [path]+ Nothing -> case lookupProgram arProgram (withPrograms lbi) of+ Just ar -> rawSystemProgram verbosity ar ["-s", path]+ Nothing -> warn verbosity $+ "Unable to generate a symbol index for the static "+ ++ "library '" ++ path+ ++ "' (missing the 'ranlib' and 'ar' programs)"
− Distribution/Simple/GHC/PackageConfig.hs
@@ -1,169 +0,0 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- Module : Distribution.Simple.GHC.PackageConfig--- Copyright : (c) The University of Glasgow 2004--- --- Maintainer : libraries@haskell.org--- Stability : alpha--- Portability : portable------ Explanation: Performs registration for GHC. Specific to--- ghc-pkg. Creates a GHC package config file. See also--- 'Distribution.Simple.GHC.build', etc.--module Distribution.Simple.GHC.PackageConfig (- GHCPackageConfig(..),- mkGHCPackageConfig,- defaultGHCPackageConfig,- showGHCPackageConfig,-- localPackageConfig, maybeCreateLocalPackageConfig,- canWriteLocalPackageConfig, canReadLocalPackageConfig- ) where--import Distribution.PackageDescription (PackageDescription(..), BuildInfo(..), Library(..))-import Distribution.Package (PackageIdentifier(..), showPackageId)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), absoluteInstallDirs)-import Distribution.Simple.InstallDirs (InstallDirs(..))-import Distribution.Simple.Setup (CopyDest(..))--#ifndef __NHC__-import Control.Exception (try)-#else-import IO (try)-#endif-import Control.Monad(unless)-import Text.PrettyPrint.HughesPJ-import System.Directory (doesFileExist, getPermissions, Permissions (..))-import System.FilePath ((</>))-import Distribution.Compat.Directory (getHomeDirectory)---- |Where ghc versions < 6.3 keeps the --user files.--- |return the file, whether it exists, and whether it's readable--localPackageConfig :: IO FilePath-localPackageConfig = do u <- getHomeDirectory- return $ (u </> ".ghc-packages")---- |If the package file doesn't exist, we should try to create it. If--- it already exists, do nothing and return true. This does not take--- into account whether it is readable or writeable.-maybeCreateLocalPackageConfig :: IO Bool -- ^success?-maybeCreateLocalPackageConfig- = do f <- localPackageConfig- exists <- doesFileExist f- unless exists $ (try (writeFile f "[]\n") >> return ())- doesFileExist f----- |Helper function for canReadPackageConfig and canWritePackageConfig-checkPermission :: (Permissions -> Bool) -> IO Bool-checkPermission perm- = do f <- localPackageConfig- exists <- doesFileExist f- if exists- then getPermissions f >>= (return . perm)- else return False---- |Check for read permission on the localPackageConfig-canReadLocalPackageConfig :: IO Bool-canReadLocalPackageConfig = checkPermission readable---- |Check for write permission on the localPackageConfig-canWriteLocalPackageConfig :: IO Bool-canWriteLocalPackageConfig = checkPermission writable---- -------------------------------------------------------------------------------- GHC 6.2 PackageConfig type---- Until GHC supports the InstalledPackageInfo type above, we use its--- existing PackagConfig type.--mkGHCPackageConfig :: PackageDescription -> LocalBuildInfo -> GHCPackageConfig-mkGHCPackageConfig pkg_descr lbi- = defaultGHCPackageConfig {- name = pkgName pkg,- auto = True,- import_dirs = [libdir installDirs],- library_dirs = libdir installDirs- : maybe [] (extraLibDirs . libBuildInfo) lib,- hs_libraries = ["HS"++(showPackageId (package pkg_descr))],- extra_libraries = maybe [] (extraLibs . libBuildInfo) lib,- include_dirs = maybe [] (includeDirs . libBuildInfo) lib,- c_includes = maybe [] (includes . libBuildInfo) lib,- package_deps = map pkgName (packageDeps lbi)- }- where- pkg = package pkg_descr- lib = library pkg_descr- installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest--data GHCPackageConfig- = GHCPackage {- name :: String,- auto :: Bool,- import_dirs :: [String],- source_dirs :: [String],- library_dirs :: [String],- hs_libraries :: [String],- extra_libraries :: [String],- include_dirs :: [String],- c_includes :: [String],- package_deps :: [String],- extra_ghc_opts :: [String],- extra_cc_opts :: [String],- extra_ld_opts :: [String],- framework_dirs :: [String], -- ignored everywhere but on Darwin/MacOS X- extra_frameworks:: [String] -- ignored everywhere but on Darwin/MacOS X- }--defaultGHCPackageConfig :: GHCPackageConfig-defaultGHCPackageConfig- = GHCPackage {- name = error "defaultPackage",- auto = False,- import_dirs = [],- source_dirs = [],- library_dirs = [],- hs_libraries = [],- extra_libraries = [],- include_dirs = [],- c_includes = [],- package_deps = [],- extra_ghc_opts = [],- extra_cc_opts = [],- extra_ld_opts = [],- framework_dirs = [],- extra_frameworks= []- }---- ------------------------------------------------------------------------------ Pretty printing package info--showGHCPackageConfig :: GHCPackageConfig -> String-showGHCPackageConfig pkg = render $- text "Package" $$ nest 3 (braces (- sep (punctuate comma [- text "name = " <> text (show (name pkg)),- text "auto = " <> text (show (auto pkg)),- dumpField "import_dirs" (import_dirs pkg),- dumpField "source_dirs" (source_dirs pkg),- dumpField "library_dirs" (library_dirs pkg),- dumpField "hs_libraries" (hs_libraries pkg),- dumpField "extra_libraries" (extra_libraries pkg),- dumpField "include_dirs" (include_dirs pkg),- dumpField "c_includes" (c_includes pkg),- dumpField "package_deps" (package_deps pkg),- dumpField "extra_ghc_opts" (extra_ghc_opts pkg),- dumpField "extra_cc_opts" (extra_cc_opts pkg),- dumpField "extra_ld_opts" (extra_ld_opts pkg),- dumpField "framework_dirs" (framework_dirs pkg),- dumpField "extra_frameworks"(extra_frameworks pkg)- ])))--dumpField :: String -> [String] -> Doc-dumpField name' val = hang (text name' <+> equals) 2 (dumpFieldContents val)--dumpFieldContents :: [String] -> Doc-dumpFieldContents val = brackets (sep (punctuate comma (map (text . show) val)))
+ Distribution/Simple/GHC/mkGHCMakefile.sh view
@@ -0,0 +1,7 @@+#!/bin/sh+file=Makefile.hs+echo "-- DO NOT EDIT: change Makefile.in, and run ./mkGHCMakefile.sh" >$file+echo "module Distribution.Simple.GHC.Makefile where {" >>$file+echo "makefileTemplate :: String; makefileTemplate=unlines" >>$file+ghc -e "readFile \"Makefile.in\" >>= print . lines" >>$file+echo "}" >>$file
Distribution/Simple/Haddock.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Haddock@@ -47,84 +46,103 @@ ) where -- local-import Distribution.Compat.ReadP(readP_to_S)-import Distribution.Package (showPackageId)-import Distribution.PackageDescription-import Distribution.ParseUtils(Field(..), readFields, parseCommaList, parseFilePathQ)-import Distribution.Simple.Program(ConfiguredProgram(..), requireProgram, - lookupProgram, programPath, ghcPkgProgram,- hscolourProgram, haddockProgram, rawSystemProgram, rawSystemProgramStdoutConf,- ghcProgram)+import Distribution.Package+ ( PackageIdentifier, Package(..) )+import Distribution.PackageDescription as PD+ (PackageDescription(..), BuildInfo(..), hcOptions,+ Library(..), hasLibs, withLib,+ Executable(..), withExe)+import Distribution.Simple.Compiler+ ( Compiler(..), CompilerFlavor(..), compilerVersion+ , extensionsToFlags )+import Distribution.Simple.Program+ ( ConfiguredProgram(..), requireProgram+ , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout+ , hscolourProgram, haddockProgram, ghcProgram ) import Distribution.Simple.PreProcess (ppCpp', ppUnlit, preprocessSources, PPSuffixHandler, runSimplePreProcessor) import Distribution.Simple.Setup import Distribution.Simple.Build (initialBuildSteps)-import Distribution.Simple.InstallDirs (InstallDirTemplates(..),+import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, PathTemplateVariable(..), toPathTemplate, fromPathTemplate, substPathTemplate, initialPathTemplateEnv)-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), hscolourPref,- haddockPref, distPref, autogenModulesDir )-import Distribution.Simple.Utils (die, warn, notice, createDirectoryIfMissingVerbose,- moduleToFilePath, findFile)+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.BuildPaths ( haddockPref, haddockName,+ hscolourPref, autogenModulesDir )+import qualified Distribution.Simple.PackageIndex as PackageIndex+ ( lookupPackageId )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+ ( InstalledPackageInfo_(..) )+import Distribution.Simple.Utils+ ( die, warn, notice, intercalate, setupMessage+ , createDirectoryIfMissingVerbose, withTempFile+ , findFileWithExtension, findFile, dotToSep )+import Distribution.Text+ ( display, simpleParse ) -import Distribution.Simple.Utils (rawSystemStdout) import Distribution.Verbosity import Language.Haskell.Extension -- Base-import System.Directory(removeFile, doesFileExist)+import System.Directory(removeFile, doesFileExist,+ removeDirectoryRecursive, copyFile) -import Control.Monad (liftM, when, unless, join)-import Data.Maybe ( isJust, catMaybes, fromJust )+import Control.Monad ( when, unless )+import Data.Maybe ( isJust, fromJust, listToMaybe ) import Data.Char (isSpace) import Data.List (nub) -import Distribution.Compat.Directory(removeDirectoryRecursive, copyFile) import System.FilePath((</>), (<.>), splitFileName, splitExtension,- replaceExtension)+ replaceExtension, normalise)+import System.IO (hClose, hPutStrLn) import Distribution.Version-import Distribution.Simple.Compiler (compilerVersion, extensionsToFlags) -- -------------------------------------------------------------------------- -- Haddock support haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () haddock pkg_descr _ _ haddockFlags- | not (hasLibs pkg_descr) && not (haddockExecutables haddockFlags) =- warn (haddockVerbose haddockFlags) $+ | not (hasLibs pkg_descr)+ && not (fromFlag $ haddockExecutables haddockFlags) =+ warn (fromFlag $ haddockVerbosity haddockFlags) $ "No documentation was generated as this package does not contain "- ++ "a\nlibrary. Perhaps you want to use the haddock command with the "- ++ "--executables flag."+ ++ "a library. Perhaps you want to use the haddock command with the "+ ++ "--executables." -haddock pkg_descr lbi suffixes haddockFlags@HaddockFlags {- haddockExecutables = doExes,- haddockHscolour = hsColour,- haddockHscolourCss = hsColourCss,- haddockVerbose = verbosity- } = do- when hsColour $ hscolour pkg_descr lbi suffixes $- HscolourFlags hsColourCss doExes verbosity+haddock pkg_descr lbi suffixes flags = do+ let distPref = fromFlag (haddockDistPref flags)+ doExes = fromFlag (haddockExecutables flags)+ hsColour = fromFlag (haddockHscolour flags)+ when hsColour $ hscolour pkg_descr lbi suffixes defaultHscolourFlags {+ hscolourCSS = haddockHscolourCss flags,+ hscolourExecutables = haddockExecutables flags,+ hscolourVerbosity = haddockVerbosity flags+ } (confHaddock, _) <- requireProgram verbosity haddockProgram (orLaterVersion (Version [0,6] [])) (withPrograms lbi) let tmpDir = buildDir lbi </> "tmp" createDirectoryIfMissingVerbose verbosity True tmpDir- createDirectoryIfMissingVerbose verbosity True $ haddockPref pkg_descr+ createDirectoryIfMissingVerbose verbosity True $+ haddockPref distPref pkg_descr preprocessSources pkg_descr lbi False verbosity suffixes - setupMessage verbosity "Running Haddock for" pkg_descr+ setupMessage verbosity "Running Haddock for" (packageId pkg_descr) let replaceLitExts = map ( (tmpDir </>) . (`replaceExtension` "hs") )- let showPkg = showPackageId (package pkg_descr)- let outputFlag = if haddockHoogle haddockFlags- then "--hoogle"- else "--html"+ let showPkg = display (packageId pkg_descr)+ let hoogle = fromFlag (haddockHoogle flags)+ outputFlag | hoogle = "--hoogle"+ | otherwise = "--html" let Just version = programVersion confHaddock let have_src_hyperlink_flags = version >= Version [0,8] [] isVersion2 = version >= Version [2,0] [] + when (hoogle && isVersion2) $+ die $ "haddock 2.x does not support the --hoogle flag."+ let mockFlags | isVersion2 = [] | otherwise = ["-D__HADDOCK__"]@@ -132,8 +150,7 @@ let mockAll bi = mapM_ (mockPP mockFlags bi tmpDir) let comp = compiler lbi- Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)- let cssFileFlag = case haddockCss haddockFlags of+ let cssFileFlag = case flagToMaybe $ haddockCss flags of Nothing -> [] Just cssFile -> ["--css=" ++ cssFile] let verboseFlags = if verbosity > deafening then ["--verbose"] else []@@ -144,44 +161,17 @@ ,"--source-entity=src/%{MODULE/./-}.html#%{NAME}"] else [] - let getField pkgId f = do- let name = showPackageId pkgId- s <- rawSystemStdout verbosity (programPath pkgTool) ["field", name, f]- case readFields s of- (ParseOk _ ((F _ _ fieldVal):_)) ->- return . join . join . take 1 . map fst . filter (null . snd)- . readP_to_S (parseCommaList parseFilePathQ) $ fieldVal- _ -> do- warn verbosity $ "Unrecognised output from ghc-pkg field "- ++ name ++ " " ++ f ++ ": " ++ s- return []- let makeReadInterface pkgId = do- interface <- getField pkgId "haddock-interfaces"- html <- case haddockHtmlLocation haddockFlags of- Nothing -> getField pkgId "haddock-html"- Just htmlStrTemplate ->- let env0 = initialPathTemplateEnv pkgId (compilerId comp)- prefixSubst = prefixDirTemplate (installDirTemplates lbi)- env = (PrefixVar, prefixSubst) : env0- expandTemplateVars = fromPathTemplate- . substPathTemplate env- . toPathTemplate- in return (expandTemplateVars htmlStrTemplate)- interfaceExists <- doesFileExist interface- if interfaceExists- then return $ Just $ "--read-interface="- ++ (if null html then "" else html ++ ",")- ++ interface- else do warn verbosity $ "The documentation for package "- ++ showPackageId pkgId ++ " is not installed. "- ++ "No links to it will be generated."- return Nothing-- packageFlags <- liftM catMaybes $ mapM makeReadInterface (packageDeps lbi)+ let htmlTemplate = fmap toPathTemplate $+ flagToMaybe (haddockHtmlLocation flags)+ packageFlags <- do+ (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate+ maybe (return ()) (warn verbosity) warnings+ return packageFlags when isVersion2 $ do- strHadGhcVers <- rawSystemProgramStdoutConf verbosity haddockProgram (withPrograms lbi) ["--ghc-version"]- let mHadGhcVers = readVersion strHadGhcVers+ strHadGhcVers <- rawSystemProgramStdout verbosity confHaddock ["--ghc-version"]+ let mHadGhcVers :: Maybe Version+ mHadGhcVers = simpleParse strHadGhcVers when (mHadGhcVers == Nothing) $ die "Could not get GHC version from Haddock" when (fromJust mHadGhcVers /= compilerVersion comp) $ die "Haddock's internal GHC version must match the configured GHC version"@@ -197,106 +187,163 @@ then ("-B" ++ ghcLibDir) : map ("--optghc=" ++) (ghcSimpleOptions lbi bi preprocessDir) else [] - when isVersion2 $ initialBuildSteps pkg_descr lbi verbosity suffixes+ when isVersion2 $+ initialBuildSteps distPref pkg_descr lbi verbosity suffixes withLib pkg_descr () $ \lib -> do let bi = libBuildInfo lib- modules = exposedModules lib ++ otherModules bi- inFiles <- getModulePaths lbi bi modules+ modules = PD.exposedModules lib ++ otherModules bi+ inFiles <- getLibSourceFiles lbi lib unless isVersion2 $ mockAll bi inFiles- let prologName = distPref </> showPkg ++ "-haddock-prolog.txt"- prolog | null (description pkg_descr) = synopsis pkg_descr- | otherwise = description pkg_descr+ let template = showPkg ++ "-haddock-prolog.txt"+ prolog | null (PD.description pkg_descr) = synopsis pkg_descr+ | otherwise = PD.description pkg_descr subtitle | null (synopsis pkg_descr) = "" | otherwise = ": " ++ synopsis pkg_descr- writeFile prologName (prolog ++ "\n")- let targets- | isVersion2 = modules- | otherwise = replaceLitExts inFiles- let haddockFile = haddockPref pkg_descr </> haddockName pkg_descr- -- FIX: replace w/ rawSystemProgramConf?- rawSystemProgram verbosity confHaddock- ([outputFlag,- "--odir=" ++ haddockPref pkg_descr,- "--title=" ++ showPkg ++ subtitle,- "--dump-interface=" ++ haddockFile,- "--prologue=" ++ prologName]- ++ packageName- ++ cssFileFlag- ++ linkToHscolour- ++ packageFlags- ++ programArgs confHaddock- ++ verboseFlags- ++ map ("--hide=" ++) (otherModules bi)- ++ haddock2options bi (buildDir lbi)- ++ targets- )- removeFile prologName- notice verbosity $ "Documentation created: "- ++ (haddockPref pkg_descr </> "index.html")+ titleComment | fromFlag (haddockInternal flags) = " (internal documentation)"+ | otherwise = ""+ withTempFile distPref template $ \prologFileName prologFileHandle -> do+ hPutStrLn prologFileHandle prolog+ hClose prologFileHandle+ let targets+ | isVersion2 = 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)+ let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"]+ | otherwise = []+ rawSystemProgram verbosity confHaddock+ ([ outputFlag+ , "--odir=" ++ haddockPref distPref pkg_descr+ , "--title=" ++ showPkg ++ subtitle ++ titleComment+ , "--dump-interface=" ++ haddockFile+ , "--prologue=" ++ prologFileName ]+ ++ packageName+ ++ cssFileFlag+ ++ linkToHscolour+ ++ packageFlags+ ++ programArgs confHaddock+ ++ verboseFlags+ ++ hideArgs+ ++ exportsFlags+ ++ haddock2options bi (buildDir lbi)+ ++ targets+ )+ notice verbosity $ "Documentation created: "+ ++ (haddockPref distPref pkg_descr </> "index.html") withExe pkg_descr $ \exe -> when doExes $ do let bi = buildInfo exe- exeTargetDir = haddockPref pkg_descr </> exeName exe+ exeTargetDir = haddockPref distPref pkg_descr </> exeName exe createDirectoryIfMissingVerbose verbosity True exeTargetDir- inFiles' <- getModulePaths lbi bi (otherModules bi)- srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)- let inFiles = srcMainPath : inFiles'+ inFiles@(srcMainPath:_) <- getExeSourceFiles lbi exe mockAll bi inFiles- let prologName = distPref </> showPkg ++ "-haddock-prolog.txt"- prolog | null (description pkg_descr) = synopsis pkg_descr- | otherwise = description pkg_descr- writeFile prologName (prolog ++ "\n")- let targets- | isVersion2 = srcMainPath : otherModules bi- | otherwise = replaceLitExts inFiles- let preprocessDir = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"- rawSystemProgram verbosity confHaddock- ([outputFlag,- "--odir=" ++ exeTargetDir,- "--title=" ++ exeName exe,- "--prologue=" ++ prologName]- ++ linkToHscolour- ++ packageFlags- ++ programArgs confHaddock- ++ verboseFlags- ++ haddock2options bi preprocessDir- ++ targets- )- removeFile prologName- notice verbosity $ "Documentation created: "- ++ (exeTargetDir </> "index.html")+ let template = showPkg ++ "-haddock-prolog.txt"+ prolog | null (PD.description pkg_descr) = synopsis pkg_descr+ | otherwise = PD.description pkg_descr+ titleComment | fromFlag (haddockInternal flags) = " (internal documentation)"+ | otherwise = ""+ withTempFile distPref template $ \prologFileName prologFileHandle -> do+ hPutStrLn prologFileHandle prolog+ hClose prologFileHandle+ let targets+ | isVersion2 = srcMainPath : otherModules bi+ | otherwise = replaceLitExts inFiles+ let preprocessDir = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"+ let exportsFlags | fromFlag (haddockInternal flags) = ["--ignore-all-exports"]+ | otherwise = []+ rawSystemProgram verbosity confHaddock+ ([ outputFlag+ , "--odir=" ++ exeTargetDir+ , "--title=" ++ exeName exe ++ titleComment+ , "--prologue=" ++ prologFileName ]+ ++ linkToHscolour+ ++ packageFlags+ ++ programArgs confHaddock+ ++ verboseFlags+ ++ exportsFlags+ ++ haddock2options bi preprocessDir+ ++ targets+ )+ notice verbosity $ "Documentation created: "+ ++ (exeTargetDir </> "index.html") removeDirectoryRecursive tmpDir where+ verbosity = fromFlag (haddockVerbosity flags) mockPP inputArgs bi pref file = do let (filePref, fileName) = splitFileName file let targetDir = pref </> filePref let targetFile = targetDir </> fileName let (targetFileNoext, targetFileExt) = splitExtension targetFile+ let cppOutput = targetFileNoext <.> "hspp"+ let hsFile = targetFileNoext <.> "hs" createDirectoryIfMissingVerbose verbosity True targetDir- if needsCpp bi- then runSimplePreProcessor (ppCpp' inputArgs bi lbi)- file targetFile verbosity- else copyFile file targetFile- when (targetFileExt == ".lhs") $ do- runSimplePreProcessor ppUnlit- targetFile (targetFileNoext <.> "hs") verbosity- return ()+ -- Run unlit first, then CPP+ if (targetFileExt == ".lhs")+ then runSimplePreProcessor ppUnlit file hsFile verbosity+ else copyFile file hsFile+ when (needsCpp bi) $ do+ runSimplePreProcessor (ppCpp' inputArgs bi lbi)+ hsFile cppOutput verbosity+ removeFile hsFile+ copyFile cppOutput hsFile+ removeFile cppOutput needsCpp :: BuildInfo -> Bool needsCpp bi = CPP `elem` extensions bi +haddockPackageFlags :: LocalBuildInfo+ -> Maybe PathTemplate+ -> IO ([String], Maybe String)+haddockPackageFlags lbi htmlTemplate = do+ interfaces <- sequence+ [ case interfaceAndHtmlPath pkgid of+ Nothing -> return (pkgid, Nothing)+ Just (interface, html) -> do+ exists <- doesFileExist interface+ if exists+ then return (pkgid, Just (interface, html))+ else return (pkgid, Nothing)+ | pkgid <- packageDeps lbi ] + let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]+ warning = "The documentation for the following packages are not "+ ++ "installed. No links will be generated to these packages: "+ ++ intercalate ", " (map display missing)+ flags = [ "--read-interface="+ ++ (if null html then "" else html ++ ",") ++ interface+ | (_, Just (interface, html)) <- interfaces ]++ return (flags, if null missing then Nothing else Just warning)++ where+ interfaceAndHtmlPath :: PackageIdentifier -> Maybe (FilePath, FilePath)+ interfaceAndHtmlPath pkgId = do+ pkg <- PackageIndex.lookupPackageId (installedPkgs lbi) pkgId+ interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)+ html <- case htmlTemplate of+ Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+ Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)+ return (interface, html)++ where expandTemplateVars = fromPathTemplate . substPathTemplate env+ env = (PrefixVar, prefix (installDirTemplates lbi))+ : initialPathTemplateEnv pkgId (compilerId (compiler lbi))++ ghcSimpleOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] ghcSimpleOptions lbi bi mockDir = ["-hide-all-packages"]- ++ (concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ])+ ++ (concat [ ["-package", display pkg] | pkg <- packageDeps lbi ]) ++ ["-i"]- ++ hcOptions GHC (options bi)- ++ ["-i" ++ autogenModulesDir lbi]+ ++ hcOptions GHC bi ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]+ ++ ["-i" ++ autogenModulesDir lbi] ++ ["-i" ++ mockDir]- ++ ["-I" ++ dir | dir <- includeDirs bi]+ ++ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ ["-odir", mockDir] ++ ["-hidir", mockDir] ++ extensionsToFlags c (extensions bi)@@ -307,23 +354,25 @@ -- hscolour support hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()-hscolour pkg_descr lbi suffixes (HscolourFlags stylesheet doExes verbosity) = do+hscolour pkg_descr lbi suffixes flags = do+ let distPref = fromFlag $ hscolourDistPref flags (hscolourProg, _) <- requireProgram verbosity hscolourProgram (orLaterVersion (Version [1,8] [])) (withPrograms lbi) - createDirectoryIfMissingVerbose verbosity True $ hscolourPref pkg_descr+ createDirectoryIfMissingVerbose verbosity True $+ hscolourPref distPref pkg_descr preprocessSources pkg_descr lbi False verbosity suffixes - setupMessage verbosity "Running hscolour for" pkg_descr+ setupMessage verbosity "Running hscolour for" (packageId pkg_descr) let replaceDot = map (\c -> if c == '.' then '-' else c) withLib pkg_descr () $ \lib -> when (isJust $ library pkg_descr) $ do let bi = libBuildInfo lib- modules = exposedModules lib ++ otherModules bi- outputDir = hscolourPref pkg_descr </> "src"+ modules = PD.exposedModules lib ++ otherModules bi+ outputDir = hscolourPref distPref pkg_descr </> "src" createDirectoryIfMissingVerbose verbosity True outputDir copyCSS hscolourProg outputDir- inFiles <- getModulePaths lbi bi modules+ inFiles <- getLibSourceFiles lbi lib flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> let outFile = outputDir </> replaceDot mo <.> "html" in rawSystemProgram verbosity hscolourProg@@ -332,11 +381,10 @@ withExe pkg_descr $ \exe -> when doExes $ do let bi = buildInfo exe modules = "Main" : otherModules bi- outputDir = hscolourPref pkg_descr </> exeName exe </> "src"+ outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src" createDirectoryIfMissingVerbose verbosity True outputDir copyCSS hscolourProg outputDir- srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)- inFiles <- liftM (srcMainPath :) $ getModulePaths lbi bi (otherModules bi)+ inFiles <- getExeSourceFiles lbi exe flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> let outFile = outputDir </> replaceDot mo <.> "html" in rawSystemProgram verbosity hscolourProg@@ -348,10 +396,32 @@ ["-print-css", "-o" ++ dir </> "hscolour.css"] | otherwise -> return () Just s -> copyFile s (dir </> "hscolour.css")+ doExes = fromFlag (hscolourExecutables flags)+ stylesheet = flagToMaybe (hscolourCSS flags)+ verbosity = fromFlag (hscolourVerbosity flags) ---TODO: where to put this? it's duplicated in .Simple too-getModulePaths :: LocalBuildInfo -> BuildInfo -> [String] -> IO [FilePath]-getModulePaths lbi bi =- fmap concat .- mapM (flip (moduleToFilePath (buildDir lbi : hsSourceDirs bi)) ["hs", "lhs"])+getLibSourceFiles :: LocalBuildInfo -> Library -> IO [FilePath]+getLibSourceFiles lbi lib = sequence+ [ findFileWithExtension ["hs", "lhs"] (preprocessDir : hsSourceDirs bi)+ (dotToSep 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_++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)+ | 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_
Distribution/Simple/Hugs.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Hugs@@ -46,11 +45,10 @@ ) where import Distribution.PackageDescription- ( PackageDescription(..), BuildInfo(..),- withLib,- Executable(..), withExe, Library(..),- libModules, hcOptions, autogenModuleName )-import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..), Flag )+ ( PackageDescription(..), BuildInfo(..), hcOptions,+ Executable(..), withExe, Library(..), withLib, libModules )+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag ) import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, requireProgram, rawSystemProgramConf, ffihugsProgram, hugsProgram )@@ -59,31 +57,30 @@ import Distribution.Simple.PreProcess.Unlit ( unlit ) import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(..), autogenModulesDir )-import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, dotToSep,- moduleToFilePath, die, info, notice,- smartCopySources, findFile, dllExtension )+ ( LocalBuildInfo(..))+import Distribution.Simple.BuildPaths+ ( autogenModuleName, autogenModulesDir,+ dllExtension )+import Distribution.Simple.Utils+ ( createDirectoryIfMissingVerbose, readUTF8File+ , findFile, dotToSep, findFileWithExtension, smartCopySources+ , die, info, notice ) import Language.Haskell.Extension ( Extension(..) )-import Distribution.Compat.Directory- ( copyFile, removeDirectoryRecursive ) import System.FilePath ( (</>), takeExtension, (<.>), searchPathSeparator, normalise, takeDirectory ) import Distribution.System+ ( OS(..), buildOS ) import Distribution.Verbosity-import Distribution.Package ( PackageIdentifier(..) ) import Data.Char ( isSpace )-import Data.Maybe ( mapMaybe )+import Data.Maybe ( mapMaybe, catMaybes ) import Control.Monad ( unless, when, filterM )-#ifndef __NHC__ import Control.Exception ( try )-#else-import IO ( try )-#endif import Data.List ( nub, sort, isSuffixOf ) import System.Directory ( Permissions(..), getPermissions,- setPermissions )+ setPermissions, copyFile,+ removeDirectoryRecursive ) -- -----------------------------------------------------------------------------@@ -98,8 +95,7 @@ (_hugsProg, conf'') <- requireProgram verbosity hugsProgram AnyVersion conf' let comp = Compiler {- compilerFlavor = Hugs,- compilerId = PackageIdentifier "hugs" (Version [] []),+ compilerId = CompilerId Hugs (Version [] []), compilerExtensions = hugsLanguageExtensions } return (comp, conf'')@@ -170,18 +166,19 @@ let srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs info verbosity $ "Source directories: " ++ show srcDirs flip mapM_ mods $ \ m -> do- fs <- moduleToFilePath srcDirs m suffixes+ fs <- findFileWithExtension suffixes srcDirs (dotToSep m) case fs of- [] ->+ Nothing -> die ("can't find source for module " ++ m)- srcFile:_ -> do+ Just srcFile -> do let ext = takeExtension srcFile copyModule useCpp bi srcFile (destDir </> dotToSep m <.> ext) -- Pass 2: compile foreign stubs in scratch directory- stubsFileLists <- sequence [moduleToFilePath [destDir] modu suffixes |- modu <- mods]- compileFiles bi destDir (concat stubsFileLists)+ stubsFileLists <- fmap catMaybes $ sequence+ [ findFileWithExtension suffixes [destDir] (dotToSep modu)+ | modu <- mods]+ compileFiles bi destDir stubsFileLists suffixes = ["hs", "lhs"] @@ -190,7 +187,7 @@ copyModule cppAll bi srcFile destFile = do createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) (exts, opts, _) <- getOptionsFromSource srcFile- let ghcOpts = hcOptions GHC opts+ 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 ()@@ -213,7 +210,7 @@ compileFFI :: BuildInfo -> FilePath -> FilePath -> IO () compileFFI bi modDir file = do (_, opts, file_incs) <- getOptionsFromSource file- let ghcOpts = hcOptions GHC opts+ let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi] let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs)) let pathFlag = "-P" ++ modDir ++ [searchPathSeparator]@@ -254,8 +251,10 @@ -- Get the non-literate source of a Haskell module. readHaskellFile :: FilePath -> IO String readHaskellFile file = do- text <- readFile file- return $ if ".lhs" `isSuffixOf` file then unlit file text else text+ text <- readUTF8File file+ if ".lhs" `isSuffixOf` file+ then either return die (unlit file text)+ else return text -- ------------------------------------------------------------ -- * options in source files@@ -270,12 +269,14 @@ [String] -- INCLUDE pragmas ) getOptionsFromSource file = do- text <- readFile file+ 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 $- if ".lhs" `isSuffixOf` file then unlit file text else text+ stripComments True text' where textLine [] = False textLine ('#':_) = False textLine _ = True@@ -349,11 +350,12 @@ -> FilePath -- ^Executable install location -> FilePath -- ^Program location on target system -> FilePath -- ^Build location+ -> (FilePath,FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> IO ()-install verbosity libDir installProgDir binDir targetProgDir buildPref pkg_descr = do+install verbosity libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do try $ removeDirectoryRecursive libDir- smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes True False+ smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes let buildProgDir = buildPref </> "programs" when (any (buildable . buildInfo) (executables pkg_descr)) $ createDirectoryIfMissingVerbose verbosity True binDir@@ -363,16 +365,17 @@ let targetDir = targetProgDir </> exeName exe try $ removeDirectoryRecursive installDir smartCopySources verbosity [theBuildDir] installDir- ("Main" : autogenModuleName pkg_descr : otherModules (buildInfo exe)) hugsInstallSuffixes True False+ ("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- let hugsOptions = hcOptions Hugs (options (buildInfo exe))- let exeFile = case os of- Windows _ -> binDir </> exeName exe <.> ".bat"- _ -> binDir </> exeName exe- let script = case os of- Windows _ ->+ let hugsOptions = hcOptions Hugs (buildInfo exe)+ let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix+ let exeFile = case buildOS of+ Windows -> binDir </> baseExeFile <.> ".bat"+ _ -> binDir </> baseExeFile+ let script = case buildOS of+ Windows -> let args = hugsOptions ++ [targetName, "%*"] in unlines ["@echo off", unwords ("runhugs" : args)]
Distribution/Simple/Install.hs view
@@ -1,11 +1,3 @@-{-# OPTIONS -cpp #-}-{-# OPTIONS -w #-}--- The above warning supression flag is a temporary kludge.--- While working on this module you are encouraged to remove it and fix--- any warnings in the module. See--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings--- for details- ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Install@@ -51,45 +43,35 @@ module Distribution.Simple.Install ( install,-#ifdef DEBUG - hunitTests-#endif ) where -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604-#if __GLASGOW_HASKELL__ < 603-#include "config.h"-#else-#include "ghcconfig.h"-#endif-#endif--import Distribution.Package (PackageIdentifier(..)) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..),- hasLibs, withLib, hasExes, withExe, haddockName )+ hasLibs, withLib, hasExes, withExe )+import Distribution.Package (Package(..)) import Distribution.Simple.LocalBuildInfo (- LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, haddockPref)+ LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,+ substPathTemplate)+import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, copyFileVerbose, die, info, notice, copyDirectoryRecursiveVerbose)-import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..))-import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..))+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), compilerFlavor )+import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag) import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.NHC as NHC import qualified Distribution.Simple.JHC as JHC import qualified Distribution.Simple.Hugs as Hugs import Control.Monad (when, unless)-import Distribution.Compat.Directory(doesDirectoryExist, doesFileExist)-import System.FilePath(takeDirectory, (</>), isAbsolute)+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath+ ( takeFileName, takeDirectory, (</>), isAbsolute ) import Distribution.Verbosity -#ifdef DEBUG-import Test.HUnit (Test)-#endif- -- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" -- actions. Move files into place based on the prefix argument. FIX: -- nhc isn't implemented yet.@@ -98,8 +80,11 @@ -> LocalBuildInfo -- ^information from the configure step -> CopyFlags -- ^flags sent to copy or install -> IO ()-install pkg_descr lbi (CopyFlags copydest verbosity) = do- let InstallDirs {+install pkg_descr lbi flags = do+ let distPref = fromFlag (copyDistPref flags)+ verbosity = fromFlag (copyVerbosity flags)+ copydest = fromFlag (copyDest' flags)+ InstallDirs { bindir = binPref, libdir = libPref, dynlibdir = dynlibPref,@@ -107,33 +92,44 @@ progdir = progPref, docdir = docPref, htmldir = htmlPref,- interfacedir = interfacePref,+ haddockdir = interfacePref, includedir = incPref } = absoluteInstallDirs pkg_descr lbi copydest- docExists <- doesDirectoryExist $ haddockPref pkg_descr- info verbosity ("directory " ++ haddockPref pkg_descr +++ + 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 dir = takeDirectory file createDirectoryIfMissingVerbose verbosity True (dataPref </> dir)- copyFileVerbose verbosity file (dataPref </> file)+ copyFileVerbose verbosity (dataDir pkg_descr </> file) (dataPref </> file) when docExists $ do createDirectoryIfMissingVerbose verbosity True htmlPref- copyDirectoryRecursiveVerbose verbosity (haddockPref pkg_descr) htmlPref+ copyDirectoryRecursiveVerbose verbosity+ (haddockPref distPref pkg_descr) htmlPref -- setPermissionsRecursive [Read] htmlPref -- The haddock interface file actually already got installed -- in the recursive copy, but now we install it where we actually -- want it to be (normally the same place). We could remove the -- copy in htmlPref first.- createDirectoryIfMissingVerbose verbosity True interfacePref- copyFileVerbose verbosity- (haddockPref pkg_descr </> haddockName pkg_descr)- (interfacePref </> haddockName pkg_descr)+ let haddockInterfaceFileSrc = haddockPref distPref pkg_descr+ </> haddockName pkg_descr+ haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr+ -- We only generate the haddock interface file for libs, So if the+ -- package consists only of executables there will not be one:+ exists <- doesFileExist haddockInterfaceFileSrc+ when exists $ do+ createDirectoryIfMissingVerbose verbosity True interfacePref+ copyFileVerbose verbosity haddockInterfaceFileSrc+ haddockInterfaceFileDest let lfile = licenseFile pkg_descr unless (null lfile) $ do createDirectoryIfMissingVerbose verbosity True docPref- copyFileVerbose verbosity lfile (docPref </> lfile)+ copyFileVerbose verbosity lfile (docPref </> takeFileName lfile) let buildPref = buildDir lbi when (hasLibs pkg_descr) $@@ -149,15 +145,16 @@ GHC -> do withLib pkg_descr () $ \_ -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr withExe pkg_descr $ \_ ->- GHC.installExe verbosity binPref buildPref pkg_descr+ GHC.installExe verbosity lbi binPref 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 pkg_descr+ withExe pkg_descr $ JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr Hugs -> do let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest) let scratchPref = scratchDir lbi- Hugs.install verbosity libPref progPref binPref targetProgPref scratchPref pkg_descr- NHC -> die ("installing with nhc98 is not yet implemented")- _ -> die ("only installing with GHC, JHC or Hugs is implemented")+ Hugs.install verbosity libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr+ NHC -> do withLib pkg_descr () $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)+ withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)+ _ -> die ("only installing with GHC, JHC, Hugs or nhc98 is implemented") return () -- register step should be performed by caller. @@ -180,11 +177,3 @@ b <- doesFileExist path if b then return (f,path) else findInc ds f installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?"---- --------------------------------------------------------------- * Testing--- -------------------------------------------------------------#ifdef DEBUG-hunitTests :: [Test]-hunitTests = []-#endif
Distribution/Simple/InstallDirs.hs view
@@ -1,11 +1,9 @@ {-# OPTIONS -cpp -fffi #-}-{-# OPTIONS -w #-}--- The above warning supression flag is a temporary kludge.--- While working on this module you are encouraged to remove it and fix--- any warnings in the module. See--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings--- for details-+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_GHC -cpp -fffi #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.InstallDirs@@ -52,10 +50,12 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.InstallDirs (- InstallDirs(..), haddockdir, haddockinterfacedir,- InstallDirTemplates(..),+ InstallDirs(..),+ InstallDirTemplates, defaultInstallDirs,+ combineInstallDirs, absoluteInstallDirs,+ CopyDest(..), prefixRelativeInstallDirs, PathTemplate,@@ -69,18 +69,21 @@ import Data.List (isPrefixOf) import Data.Maybe (fromMaybe)-import System.FilePath ((</>), isPathSeparator)+import Data.Monoid (Monoid(..))+import System.Directory (getAppUserDataDirectory)+import System.FilePath ((</>), isPathSeparator, pathSeparator) #if __HUGS__ || __GLASGOW_HASKELL__ > 606 import System.FilePath (dropDrive) #endif -import Distribution.Package (PackageIdentifier(..), showPackageId)-import Distribution.PackageDescription (PackageDescription(package))-import Distribution.Version (showVersion)-import Distribution.System (OS(..), os)-import Distribution.Simple.Compiler (CompilerFlavor(..))--- TODO: move CopyDest to this module-import Distribution.Simple.Setup (CopyDest(..))+import Distribution.Package+ ( PackageIdentifier, packageName, packageVersion )+import Distribution.System+ ( OS(..), buildOS )+import Distribution.Compiler+ ( CompilerId, CompilerFlavor(..) )+import Distribution.Text+ ( display ) #if mingw32_HOST_OS || mingw32_TARGET_OS import Foreign@@ -102,16 +105,85 @@ prefix :: dir, bindir :: dir, libdir :: dir,+ libsubdir :: dir, dynlibdir :: dir, libexecdir :: dir, progdir :: dir, includedir :: dir, datadir :: dir,+ datasubdir :: dir, docdir :: dir,+ mandir :: dir, htmldir :: dir,- interfacedir :: dir+ haddockdir :: dir } deriving (Read, Show) +instance Functor InstallDirs where+ fmap f dirs = InstallDirs {+ prefix = f (prefix dirs),+ bindir = f (bindir dirs),+ libdir = f (libdir dirs),+ libsubdir = f (libsubdir dirs),+ dynlibdir = f (dynlibdir dirs),+ libexecdir = f (libexecdir dirs),+ progdir = f (progdir dirs),+ includedir = f (includedir dirs),+ datadir = f (datadir dirs),+ datasubdir = f (datasubdir dirs),+ docdir = f (docdir dirs),+ mandir = f (mandir dirs),+ htmldir = f (htmldir dirs),+ haddockdir = f (haddockdir dirs)+ }++instance Monoid dir => Monoid (InstallDirs dir) where+ mempty = InstallDirs {+ prefix = mempty,+ bindir = mempty,+ libdir = mempty,+ libsubdir = mempty,+ dynlibdir = mempty,+ libexecdir = mempty,+ progdir = mempty,+ includedir = mempty,+ datadir = mempty,+ datasubdir = mempty,+ docdir = mempty,+ mandir = mempty,+ htmldir = mempty,+ haddockdir = mempty+ }+ mappend = combineInstallDirs mappend++combineInstallDirs :: (a -> b -> c)+ -> InstallDirs a+ -> InstallDirs b+ -> InstallDirs c+combineInstallDirs combine a b = InstallDirs {+ prefix = prefix a `combine` prefix b,+ bindir = bindir a `combine` bindir b,+ libdir = libdir a `combine` libdir b,+ libsubdir = libsubdir a `combine` libsubdir b,+ dynlibdir = dynlibdir a `combine` dynlibdir b,+ libexecdir = libexecdir a `combine` libexecdir b,+ progdir = progdir a `combine` progdir b,+ includedir = includedir a `combine` includedir b,+ datadir = datadir a `combine` datadir b,+ datasubdir = datasubdir a `combine` datasubdir b,+ docdir = docdir a `combine` docdir b,+ mandir = mandir a `combine` mandir b,+ htmldir = htmldir a `combine` htmldir b,+ haddockdir = haddockdir a `combine` haddockdir b+ }++appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a+appendSubdirs append dirs = dirs {+ libdir = libdir dirs `append` libsubdir dirs,+ datadir = datadir dirs `append` datasubdir dirs,+ libsubdir = error "internal error InstallDirs.libsubdir",+ datasubdir = error "internal error InstallDirs.datasubdir"+ }+ -- | The installation dirctories in terms of 'PathTemplate's that contain -- variables. --@@ -129,80 +201,52 @@ -- users to be able to configure @--libdir=\/usr\/lib64@ for example but -- because by default we want to support installing multiplve versions of -- packages and building the same package for multiple compilers we append the--- libdubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@.+-- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@. -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows. ---data InstallDirTemplates = InstallDirTemplates {- prefixDirTemplate :: PathTemplate,- binDirTemplate :: PathTemplate,- libDirTemplate :: PathTemplate,- libSubdirTemplate :: PathTemplate,- libexecDirTemplate :: PathTemplate,- progDirTemplate :: PathTemplate,- includeDirTemplate :: PathTemplate,- dataDirTemplate :: PathTemplate,- dataSubdirTemplate :: PathTemplate,- docDirTemplate :: PathTemplate,- htmlDirTemplate :: PathTemplate,- interfaceDirTemplate :: PathTemplate- } deriving (Read, Show)+type InstallDirTemplates = InstallDirs PathTemplate -- --------------------------------------------------------------------------- -- Default installation directories -defaultInstallDirs :: CompilerFlavor -> Bool -> IO InstallDirTemplates-defaultInstallDirs comp hasLibs = do+defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates+defaultInstallDirs comp userInstall hasLibs = do windowsProgramFilesDir <- getWindowsProgramFilesDir- let prefixDir = case os of- Windows _ -> windowsProgramFilesDir </> "Haskell"- _other -> "/usr/local"- binDir = "$prefix" </> "bin"- libDir = case os of- Windows _ -> "$prefix"- _other -> "$prefix" </> "lib"- libSubdir = case comp of+ userInstallPrefix <- getAppUserDataDirectory "cabal"+ return $ fmap toPathTemplate $ InstallDirs {+ prefix = if userInstall+ then userInstallPrefix+ else case buildOS of+ Windows -> windowsProgramFilesDir </> "Haskell"+ _other -> "/usr/local",+ bindir = "$prefix" </> "bin",+ libdir = case buildOS of+ Windows -> "$prefix"+ _other -> "$prefix" </> "lib",+ libsubdir = case comp of Hugs -> "hugs" </> "packages" </> "$pkg" JHC -> "$compiler"- _other -> "$pkgid" </> "$compiler"- libexecDir = case os of- Windows _ -> "$prefix" </> "$pkgid"- _other -> "$prefix" </> "libexec"- progDir = "$libdir" </> "hugs" </> "programs"- includeDir = "$libdir" </> "$libsubdir" </> "include"- dataDir = case os of- Windows _ | hasLibs -> windowsProgramFilesDir </> "Haskell"+ _other -> "$pkgid" </> "$compiler",+ dynlibdir = "$libdir",+ libexecdir = case buildOS of+ Windows -> "$prefix" </> "$pkgid"+ _other -> "$prefix" </> "libexec",+ progdir = "$libdir" </> "hugs" </> "programs",+ includedir = "$libdir" </> "$libsubdir" </> "include",+ datadir = case buildOS of+ Windows | hasLibs -> windowsProgramFilesDir </> "Haskell" | otherwise -> "$prefix"- _other -> "$prefix" </> "share"- dataSubdir = "$pkgid"- docDir = case os of- Windows _ -> "$prefix" </> "doc" </> "$pkgid"- _other -> "$datadir" </> "doc" </> "$pkgid"- htmlDir = "$docdir" </> "html"- interfaceDir = "$docdir" </> "html"- return InstallDirTemplates {- prefixDirTemplate = toPathTemplate prefixDir,- binDirTemplate = toPathTemplate binDir,- libDirTemplate = toPathTemplate libDir,- libSubdirTemplate = toPathTemplate libSubdir,- libexecDirTemplate = toPathTemplate libexecDir,- progDirTemplate = toPathTemplate progDir,- includeDirTemplate = toPathTemplate includeDir,- dataDirTemplate = toPathTemplate dataDir,- dataSubdirTemplate = toPathTemplate dataSubdir,- docDirTemplate = toPathTemplate docDir,- htmlDirTemplate = toPathTemplate htmlDir,- interfaceDirTemplate = toPathTemplate interfaceDir- }--haddockdir :: InstallDirs FilePath -> PackageDescription -> FilePath-haddockdir installDirs pkg_descr =- htmldir installDirs--haddockinterfacedir :: InstallDirs FilePath -> PackageDescription -> FilePath-haddockinterfacedir installDirs pkg_descr =- interfacedir installDirs+ _other -> "$prefix" </> "share",+ datasubdir = "$pkgid",+ docdir = case buildOS of+ Windows -> "$prefix" </> "doc" </> "$pkgid"+ _other -> "$datadir" </> "doc" </> "$pkgid",+ mandir = "$datadir" </> "man",+ htmldir = "$docdir" </> "html",+ haddockdir = "$htmldir"+ } -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative@@ -215,116 +259,99 @@ -- as a subsequent operation. -- -- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we--- can replace 'prefixDirTemplate' with the 'PrefixVar' and get resulting+-- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix. ---substituteTemplates :: PackageIdentifier -> PackageIdentifier+substituteTemplates :: PackageIdentifier -> CompilerId -> InstallDirTemplates -> InstallDirTemplates substituteTemplates pkgId compilerId dirs = dirs' where- dirs' = InstallDirTemplates {+ dirs' = InstallDirs { -- So this specifies exactly which vars are allowed in each template- prefixDirTemplate = subst prefixDirTemplate [],- binDirTemplate = subst binDirTemplate [prefixDirVar],- libDirTemplate = subst libDirTemplate [prefixDirVar, binDirVar],- libSubdirTemplate = subst libSubdirTemplate [],- libexecDirTemplate = subst libexecDirTemplate prefixBinLibVars,- progDirTemplate = subst progDirTemplate prefixBinLibVars,- includeDirTemplate = subst includeDirTemplate prefixBinLibVars,- dataDirTemplate = subst dataDirTemplate prefixBinLibVars,- dataSubdirTemplate = subst dataSubdirTemplate [],- docDirTemplate = subst docDirTemplate $ prefixBinLibVars- ++ [dataDirVar, dataSubdirVar],- htmlDirTemplate = subst htmlDirTemplate $ prefixBinLibVars- ++ [dataDirVar, dataSubdirVar, docDirVar],- interfaceDirTemplate = subst interfaceDirTemplate $ prefixBinLibVars- ++ [dataDirVar, dataSubdirVar, docDirVar]+ prefix = subst prefix [],+ bindir = subst bindir [prefixVar],+ libdir = subst libdir [prefixVar, bindirVar],+ libsubdir = subst libsubdir [],+ dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar],+ libexecdir = subst libexecdir prefixBinLibVars,+ progdir = subst progdir prefixBinLibVars,+ includedir = subst includedir prefixBinLibVars,+ datadir = subst datadir prefixBinLibVars,+ datasubdir = subst datasubdir [],+ docdir = subst docdir prefixBinLibDataVars,+ mandir = subst docdir (prefixBinLibDataVars ++ [docdirVar]),+ htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]),+ haddockdir = subst haddockdir (prefixBinLibDataVars +++ [docdirVar, htmldirVar]) } -- The initial environment has all the static stuff but no paths env = initialPathTemplateEnv pkgId compilerId subst dir env' = substPathTemplate (env'++env) (dir dirs) - prefixDirVar = (PrefixVar, prefixDirTemplate dirs')- binDirVar = (BinDirVar, binDirTemplate dirs')- libDirVar = (LibDirVar, libDirTemplate dirs')- libSubdirVar = (LibSubdirVar, libSubdirTemplate dirs')- dataDirVar = (DataDirVar, dataDirTemplate dirs')- dataSubdirVar = (DataSubdirVar, dataSubdirTemplate dirs')- docDirVar = (DocDirVar, docDirTemplate dirs')- prefixBinLibVars = [prefixDirVar, binDirVar, libDirVar, libSubdirVar]+ prefixVar = (PrefixVar, prefix dirs')+ bindirVar = (BindirVar, bindir dirs')+ libdirVar = (LibdirVar, libdir dirs')+ libsubdirVar = (LibsubdirVar, libsubdir dirs')+ datadirVar = (DatadirVar, datadir dirs')+ datasubdirVar = (DatasubdirVar, datasubdir dirs')+ docdirVar = (DocdirVar, docdir dirs')+ htmldirVar = (HtmldirVar, htmldir dirs')+ prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]+ prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path.-absoluteInstallDirs :: PackageIdentifier -> PackageIdentifier -> CopyDest+absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest -> InstallDirTemplates -> InstallDirs FilePath absoluteInstallDirs pkgId compilerId copydest dirs =- InstallDirs {- prefix = copy $ path prefixDirTemplate,- bindir = copy $ path binDirTemplate,- libdir = copy $ path libDirTemplate </> path libSubdirTemplate,- dynlibdir = copy $ path libDirTemplate,- libexecdir = copy $ path libexecDirTemplate,- progdir = copy $ path progDirTemplate,- includedir = copy $ path includeDirTemplate,- datadir = copy $ path dataDirTemplate </> path dataSubdirTemplate,- docdir = copy $ path docDirTemplate,- htmldir = copy $ path htmlDirTemplate,- interfacedir = copy $ path interfaceDirTemplate- }- where- dirs' = substituteTemplates pkgId compilerId dirs {- prefixDirTemplate = case copydest of- -- possibly override the prefix- CopyPrefix p -> toPathTemplate p- _ -> prefixDirTemplate dirs- }- path dir = case dir dirs' of- PathTemplate cs -> concat [ c | Ordinary c <- cs ]- copy dir = case copydest of- CopyTo destdir -> destdir </> dropDrive dir- _ -> dir+ (case copydest of+ CopyTo destdir -> fmap ((destdir </>) . dropDrive)+ _ -> id)+ . appendSubdirs (</>)+ . fmap fromPathTemplate+ $ substituteTemplates pkgId compilerId dirs {+ prefix = case copydest of+ -- possibly override the prefix+ CopyPrefix p -> toPathTemplate p+ _ -> prefix dirs+ } +-- |The location prefix for the /copy/ command.+data CopyDest+ = NoCopyDest+ | CopyTo FilePath+ | CopyPrefix FilePath -- DEPRECATED+ deriving (Eq, Show)+ -- | Check which of the paths are relative to the installation $prefix. -- -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). ---prefixRelativeInstallDirs :: PackageIdentifier -> PackageIdentifier+prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId -> InstallDirTemplates -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId compilerId dirs =- InstallDirs {- prefix = relative prefixDirTemplate,- bindir = relative binDirTemplate,- libdir = (flip fmap) (relative libDirTemplate) (</> path libSubdirTemplate),- dynlibdir = (relative libDirTemplate),- libexecdir = relative libexecDirTemplate,- progdir = relative progDirTemplate,- includedir = relative includeDirTemplate,- datadir = (flip fmap) (relative dataDirTemplate) (</> path dataSubdirTemplate),- docdir = relative docDirTemplate,- htmldir = relative htmlDirTemplate,- interfacedir = relative interfaceDirTemplate- }- where- -- substitute the path template into each other, except that we map+ fmap relative+ . appendSubdirs combinePathTemplate+ $ -- substitute the path template into each other, except that we map -- \$prefix back to $prefix. We're trying to end up with templates that -- mention no vars except $prefix.- dirs' = substituteTemplates pkgId compilerId dirs {- prefixDirTemplate = PathTemplate [Variable PrefixVar]- }+ substituteTemplates pkgId compilerId dirs {+ prefix = PathTemplate [Variable PrefixVar]+ }+ where -- If it starts with $prefix then it's relative and produce the relative -- path by stripping off $prefix/ or $prefix- relative dir = case dir dirs' of+ relative dir = case dir of PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) relative' (Variable PrefixVar : Ordinary (s:rest) : rest') | isPathSeparator s = Just (Ordinary rest : rest') relative' (Variable PrefixVar : rest) = Just rest relative' _ = Nothing- path dir = fromPathTemplate (dir dirs') -- --------------------------------------------------------------------------- -- Path templates@@ -340,12 +367,13 @@ data PathTemplateVariable = PrefixVar -- ^ The @$prefix@ path variable- | BinDirVar -- ^ The @$bindir@ path variable- | LibDirVar -- ^ The @$libdir@ path variable- | LibSubdirVar -- ^ The @$libsubdir@ path variable- | DataDirVar -- ^ The @$datadir@ path variable- | DataSubdirVar -- ^ The @$datasubdir@ path variable- | DocDirVar -- ^ The @$docdir@ path variable+ | BindirVar -- ^ The @$bindir@ path variable+ | LibdirVar -- ^ The @$libdir@ path variable+ | LibsubdirVar -- ^ The @$libsubdir@ path variable+ | DatadirVar -- ^ The @$datadir@ path variable+ | DatasubdirVar -- ^ The @$datasubdir@ path variable+ | DocdirVar -- ^ The @$docdir@ path variable+ | HtmldirVar -- ^ The @$htmldir@ path variable | PkgNameVar -- ^ The @$pkg@ package name path variable | PkgVerVar -- ^ The @$version@ package version path variable | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@@@ -357,11 +385,15 @@ toPathTemplate :: FilePath -> PathTemplate toPathTemplate = PathTemplate . read --- | Convert back to a path, ingoring any remaining vars+-- | Convert back to a path, any remaining vars are included -- fromPathTemplate :: PathTemplate -> FilePath-fromPathTemplate (PathTemplate cs) = concat [ c | Ordinary c <- cs ]+fromPathTemplate (PathTemplate template) = show template +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate+combinePathTemplate (PathTemplate t1) (PathTemplate t2) =+ PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2)+ substPathTemplate :: [(PathTemplateVariable, PathTemplate)] -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) =@@ -374,14 +406,14 @@ Nothing -> [component] -- | The initial environment has all the static stuff but no paths-initialPathTemplateEnv :: PackageIdentifier -> PackageIdentifier+initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> [(PathTemplateVariable, PathTemplate)] initialPathTemplateEnv pkgId compilerId = map (\(v,s) -> (v, PathTemplate [Ordinary s]))- [(PkgNameVar, pkgName pkgId)- ,(PkgVerVar, showVersion (pkgVersion pkgId))- ,(PkgIdVar, showPackageId pkgId)- ,(CompilerVar, showPackageId compilerId)]+ [(PkgNameVar, packageName pkgId)+ ,(PkgVerVar, display (packageVersion pkgId))+ ,(PkgIdVar, display pkgId)+ ,(CompilerVar, display compilerId)] -- --------------------------------------------------------------------------- -- Parsing and showing path templates:@@ -394,12 +426,13 @@ instance Show PathTemplateVariable where show PrefixVar = "prefix"- show BinDirVar = "bindir"- show LibDirVar = "libdir"- show LibSubdirVar = "libsubdir"- show DataDirVar = "datadir"- show DataSubdirVar = "datasubdir"- show DocDirVar = "docdir"+ show BindirVar = "bindir"+ show LibdirVar = "libdir"+ show LibsubdirVar = "libsubdir"+ show DatadirVar = "datadir"+ show DatasubdirVar = "datasubdir"+ show DocdirVar = "docdir"+ show HtmldirVar = "htmldir" show PkgNameVar = "pkg" show PkgVerVar = "version" show PkgIdVar = "pkgid"@@ -412,12 +445,13 @@ | (varStr, var) <- vars , varStr `isPrefixOf` s ] where vars = [("prefix", PrefixVar)- ,("bindir", BinDirVar)- ,("libdir", LibDirVar)- ,("libsubdir", LibSubdirVar)- ,("datadir", DataDirVar)- ,("datasubdir", DataSubdirVar)- ,("docdir", DocDirVar)+ ,("bindir", BindirVar)+ ,("libdir", LibdirVar)+ ,("libsubdir", LibsubdirVar)+ ,("datadir", DatadirVar)+ ,("datasubdir", DatasubdirVar)+ ,("docdir", DocdirVar)+ ,("htmldir", HtmldirVar) ,("pkgid", PkgIdVar) ,("pkg", PkgNameVar) ,("version", PkgVerVar)@@ -508,7 +542,7 @@ dropDrive cs = cs isWindows :: Bool-isWindows = case os of- Windows _ -> True- _ -> False+isWindows = case buildOS of+ Windows -> True+ _ -> False #endif
Distribution/Simple/JHC.hs view
@@ -44,32 +44,43 @@ configure, getInstalledPackages, build, installLib, installExe ) where -import Distribution.PackageDescription+import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), withLib, Executable(..), withExe, Library(..), libModules, hcOptions )+import Distribution.InstalledPackageInfo+ ( InstalledPackageInfo, emptyInstalledPackageInfo )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+ ( InstalledPackageInfo_(package) )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(..), - autogenModulesDir )-import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..), Flag,- PackageDB, extensionsToFlags )+ ( LocalBuildInfo(..) )+import Distribution.Simple.BuildPaths+ ( autogenModulesDir, exeExtension )+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), CompilerId(..), Compiler(..)+ , PackageDB, Flag, extensionsToFlags ) import Language.Haskell.Extension (Extension(..)) import Distribution.Simple.Program ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration, userMaybeSpecifyPath, requireProgram, lookupProgram, rawSystemProgram, rawSystemProgramStdoutConf ) import Distribution.Version ( VersionRange(AnyVersion) )-import Distribution.Package ( PackageIdentifier(..), showPackageId,- parsePackageId )-import Distribution.Simple.Utils( createDirectoryIfMissingVerbose,- copyFileVerbose, exeExtension, die, info )+import Distribution.Package+ ( Package(..) )+import Distribution.Simple.Utils+ ( createDirectoryIfMissingVerbose, copyFileVerbose+ , die, info, intercalate ) import System.FilePath ( (</>) ) import Distribution.Verbosity+import Distribution.Text+ ( Text(parse), display ) import Distribution.Compat.ReadP ( readP_to_S, many, skipSpaces ) -import Data.List ( nub, intersperse )+import Data.List ( nub ) import Data.Char ( isSpace ) @@ -86,8 +97,7 @@ let Just version = programVersion jhcProg comp = Compiler {- compilerFlavor = JHC,- compilerId = PackageIdentifier "jhc" version,+ compilerId = CompilerId JHC version, compilerExtensions = jhcLanguageExtensions } return (comp, conf')@@ -102,11 +112,15 @@ ] getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration- -> IO [PackageIdentifier]+ -> IO (PackageIndex InstalledPackageInfo) getInstalledPackages verbosity _packagedb conf = do str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"]- case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str) of- [ps] -> return ps+ case pCheck (readP_to_S (many (skipSpaces >> parse)) str) of+ [ps] -> return $ PackageIndex.fromList+ [ emptyInstalledPackageInfo {+ InstalledPackageInfo.package = p+ }+ | p <- ps ] _ -> die "cannot parse package list" where pCheck :: [(a, [Char])] -> [a]@@ -125,7 +139,7 @@ let libBi = libBuildInfo lib let args = constructJHCCmdLine lbi libBi (buildDir lbi) verbosity rawSystemProgram verbosity jhcProg (["-c"] ++ args ++ libModules pkg_descr)- let pkgid = showPackageId (package pkg_descr)+ let pkgid = display (packageId pkg_descr) pfile = buildDir lbi </> "jhc-pkg.conf" hlfile= buildDir lbi </> (pkgid ++ ".hl") writeFile pfile $ jhcPkgConf pkg_descr@@ -141,32 +155,34 @@ constructJHCCmdLine lbi bi _odir verbosity = (if verbosity >= deafening then ["-v"] else []) ++ extensionsToFlags (compiler lbi) (extensions bi)- ++ hcOptions JHC (options bi)+ ++ hcOptions JHC bi ++ ["--noauto","-i-"]- ++ ["-i", autogenModulesDir lbi] ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)]- ++ ["-optc" ++ opt | opt <- ccOptions bi]- ++ (concat [ ["-p", showPackageId pkg] | pkg <- packageDeps lbi ])+ ++ ["-i", autogenModulesDir lbi]+ ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]+ ++ (concat [ ["-p", display pkg] | pkg <- packageDeps lbi ]) jhcPkgConf :: PackageDescription -> String jhcPkgConf pd = let sline name sel = name ++ ": "++sel pd Just lib = library pd- comma f l = concat $ intersperse "," $ map f l- in unlines [sline "name" (showPackageId . package)- ,"exposed-modules: " ++ (comma id (exposedModules lib))- ,"hidden-modules: " ++ (comma id (otherModules $ libBuildInfo lib))+ comma = intercalate ","+ in unlines [sline "name" (display . packageId)+ ,"exposed-modules: " ++ (comma (PD.exposedModules lib))+ ,"hidden-modules: " ++ (comma (otherModules $ libBuildInfo lib)) ] installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () installLib verb dest build_dir pkg_descr _ = do- let p = showPackageId (package pkg_descr)++".hl"+ let p = display (packageId pkg_descr)++".hl" createDirectoryIfMissingVerbose verb True dest copyFileVerbose verb (build_dir </> p) (dest </> p) -installExe :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Executable -> IO ()-installExe verb dest build_dir _ exe = do- let out = exeName exe </> exeExtension+installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO ()+installExe verb dest build_dir (progprefix,progsuffix) _ exe = do+ let exe_name = exeName exe+ src = exe_name </> exeExtension+ out = (progprefix ++ exe_name ++ progsuffix) </> exeExtension createDirectoryIfMissingVerbose verb True dest- copyFileVerbose verb (build_dir </> out) (dest </> out)+ copyFileVerbose verb (build_dir </> src) (dest </> out)
Distribution/Simple/LocalBuildInfo.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.LocalBuildInfo@@ -49,24 +48,25 @@ -- * Installation directories module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs,- -- ** Deprecated install dir functions- mkLibDir, mkBinDir, mkLibexecDir, mkDataDir,- -- * Build directories- distPref, srcPref,- hscolourPref, haddockPref,- autogenModulesDir+ substPathTemplate,++ -- * Deprecated compat stuff+ mkDataDir, ) where import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,- prefixRelativeInstallDirs)+ prefixRelativeInstallDirs,+ substPathTemplate, ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Setup (CopyDest(..)) import Distribution.Simple.Program (ProgramConfiguration) import Distribution.PackageDescription (PackageDescription(..))-import Distribution.Package (PackageIdentifier(..))-import Distribution.Simple.Compiler (Compiler(..), PackageDB)-import System.FilePath (FilePath, (</>))+import Distribution.Package (PackageIdentifier, Package(..))+import Distribution.Simple.Compiler+ ( Compiler(..), PackageDB, OptimisationLevel )+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.InstalledPackageInfo (InstalledPackageInfo) -- |Data cached after configuration step. See also -- 'Distribution.Setup.ConfigFlags'.@@ -87,6 +87,8 @@ -- 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, -- ^ the filename containing the .cabal file, if available localPkgDescr :: PackageDescription,@@ -98,33 +100,15 @@ withProfLib :: Bool, -- ^Whether to build profiling versions of libs. withSharedLib :: Bool, -- ^Whether to build shared versions of libs. withProfExe :: Bool, -- ^Whether to build executables for profiling.- withOptimization :: Bool, -- ^Whether to build with optimization (if available).+ 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 } deriving (Read, Show) --- --------------------------------------------------------------- * Some Paths--- --------------------------------------------------------------distPref :: FilePath-distPref = "dist"--srcPref :: FilePath-srcPref = distPref </> "src"--hscolourPref :: PackageDescription -> FilePath-hscolourPref = haddockPref--haddockPref :: PackageDescription -> FilePath-haddockPref pkg_descr- = foldl1 (</>) [distPref, "doc", "html", pkgName (package pkg_descr)]---- |The directory in which we put auto-generated modules-autogenModulesDir :: LocalBuildInfo -> String-autogenModulesDir lbi = buildDir lbi </> "autogen"- -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs @@ -133,7 +117,7 @@ -> InstallDirs FilePath absoluteInstallDirs pkg_descr lbi copydest = InstallDirs.absoluteInstallDirs- (package pkg_descr)+ (packageId pkg_descr) (compilerId (compiler lbi)) copydest (installDirTemplates lbi)@@ -143,29 +127,22 @@ -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi = InstallDirs.prefixRelativeInstallDirs- (package pkg_descr)+ (packageId pkg_descr) (compilerId (compiler lbi)) (installDirTemplates lbi) --- -------------------------------------------------------------------------------- Compatability aliases--mkBinDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath-mkBinDir pkg_descr lbi copydest = - bindir (absoluteInstallDirs pkg_descr lbi copydest)-{-# DEPRECATED mkBinDir "use bindir :: InstallDirs -> FilePath" #-}--mkLibDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath-mkLibDir pkg_descr lbi copydest = - libdir (absoluteInstallDirs pkg_descr lbi copydest)-{-# DEPRECATED mkLibDir "use libdir :: InstallDirs -> FilePath" #-}--mkLibexecDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath-mkLibexecDir pkg_descr lbi copydest = - libexecdir (absoluteInstallDirs pkg_descr lbi copydest)-{-# DEPRECATED mkLibexecDir "use libexecdir :: InstallDirs -> FilePath" #-}+substPathTemplate :: PackageDescription -> LocalBuildInfo+ -> PathTemplate -> FilePath+substPathTemplate pkg_descr lbi = fromPathTemplate + . ( InstallDirs.substPathTemplate env )+ where env = initialPathTemplateEnv + (packageId pkg_descr)+ (compilerId (compiler lbi))+ +-- ---------------------------------------------------------------------------+-- Deprecated compat stuff mkDataDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath-mkDataDir pkg_descr lbi copydest = +mkDataDir pkg_descr lbi copydest = datadir (absoluteInstallDirs pkg_descr lbi copydest) {-# DEPRECATED mkDataDir "use datadir :: InstallDirs -> FilePath" #-}
Distribution/Simple/NHC.hs view
@@ -42,23 +42,42 @@ module Distribution.Simple.NHC ( configure , build-{-, install -}+ , installLib, installExe ) where +import Distribution.Package+ ( PackageIdentifier, packageName, Package(..) ) import Distribution.PackageDescription- ( PackageDescription(..), BuildInfo(..),- Library(..), libModules, hcOptions)+ ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..),+ withLib, withExe, hcOptions ) import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(..) )-import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..), Flag,- extensionsToFlags )-import Language.Haskell.Extension (Extension(..))-import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath,- requireProgram, hmakeProgram,- rawSystemProgramConf )-import Distribution.Version ( VersionRange(AnyVersion) )+ ( LocalBuildInfo(..) )+import Distribution.Simple.BuildPaths+ ( mkLibName, objExtension, exeExtension )+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), CompilerId(..), Compiler(..)+ , Flag, extensionsToFlags )+import Language.Haskell.Extension+ ( Extension(..) )+import Distribution.Simple.Program + ( ProgramConfiguration, userMaybeSpecifyPath, requireProgram,+ lookupProgram, ConfiguredProgram(programVersion), programPath,+ nhcProgram, hmakeProgram, ldProgram, arProgram,+ rawSystemProgramConf )+import Distribution.Simple.Utils+ ( die, info, findFileWithExtension, dotToSep,+ createDirectoryIfMissingVerbose, copyFileVerbose, smartCopySources )+import Distribution.Version+ ( Version(..), VersionRange(..), orLaterVersion ) import Distribution.Verbosity+import System.FilePath+ ( (</>), (<.>), normalise, takeDirectory, dropExtension )+import System.Directory+ ( removeFile ) +import Control.Exception (try)+import Data.List ( nub )+import Control.Monad ( when, unless ) -- ----------------------------------------------------------------------------- -- Configuring@@ -67,20 +86,33 @@ -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do - (_hmakeProg, conf') <- requireProgram verbosity hmakeProgram AnyVersion- (userMaybeSpecifyPath "hmake" hcPath conf)+ (nhcProg, conf') <- requireProgram verbosity nhcProgram+ (orLaterVersion (Version [1,20] []))+ (userMaybeSpecifyPath "nhc98" hcPath conf)+ let Just nhcVersion = programVersion nhcProg + (_hmakeProg, conf'') <- requireProgram verbosity hmakeProgram+ (orLaterVersion (Version [3,13] [])) conf'+ (_ldProg, conf''') <- requireProgram verbosity ldProgram AnyVersion conf''+ (_arProg, conf'''') <- requireProgram verbosity arProgram AnyVersion conf'''++ --TODO: put this stuff in a monad so we can say just:+ -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] []))+ -- requireProgram ldProgram AnyVersion+ -- requireProgram ldPrograrProgramam AnyVersion+ -- unless (null (cSources bi)) $ requireProgram ccProgram AnyVersion+ let comp = Compiler {- compilerFlavor = NHC,- compilerId = error "TODO: nhc98 compilerId", --PackageIdentifier "nhc98" version+ compilerId = CompilerId NHC nhcVersion, compilerExtensions = nhcLanguageExtensions }- return (comp, conf')+ return (comp, conf'''') -- | The flags for the supported extensions nhcLanguageExtensions :: [(Extension, Flag)] nhcLanguageExtensions =- -- NHC doesn't enforce the monomorphism restriction at all.+ -- TODO: use -98 when no extensions are specified.+ -- NHC doesn't enforce the monomorphism restriction at all. [(NoMonomorphismRestriction, "") ,(ForeignFunctionInterface, "") ,(ExistentialQuantification, "")@@ -95,15 +127,130 @@ -- |FIX: For now, the target must contain a main module. Not used -- ATM. Re-add later. build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()-build pkg_descr lbi verbosity =- -- Unsupported extensions have already been checked by configure- let flags = ( extensionsToFlags (compiler lbi)- . maybe [] (extensions . libBuildInfo)- . library ) pkg_descr in- rawSystemProgramConf verbosity hmakeProgram (withPrograms lbi)- (["-hc=nhc98"]- ++ flags- ++ maybe [] (hcOptions NHC . options . libBuildInfo)- (library pkg_descr)- ++ libModules pkg_descr)+build pkg_descr lbi verbosity = do+ let conf = withPrograms lbi+ Just nhcProg = lookupProgram nhcProgram conf+ withLib pkg_descr () $ \lib -> do+ let bi = libBuildInfo lib+ modules = exposedModules lib ++ otherModules bi+ -- Unsupported extensions have already been checked by configure+ extensionFlags = extensionsToFlags (compiler lbi) (extensions bi)+ inFiles <- getModulePaths lbi bi modules+ let targetDir = buildDir lbi+ srcDirs = nub (map takeDirectory inFiles)+ destDirs = map (targetDir </>) srcDirs+ mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs+ rawSystemProgramConf verbosity hmakeProgram conf $+ ["-hc=" ++ programPath nhcProg]+ ++ nhcVerbosityOptions verbosity+ ++ ["-d", targetDir, "-hidir", targetDir]+ ++ extensionFlags+ ++ maybe [] (hcOptions NHC . libBuildInfo)+ (library pkg_descr)+ ++ concat [ ["-package", packageName pkg] | pkg <- packageDeps lbi ]+ ++ inFiles+{-+ -- build any C sources+ unless (null (cSources bi)) $ do+ info verbosity "Building C Sources..."+ let commonCcArgs = (if verbosity > deafening then ["-v"] else [])+ ++ ["-I" ++ dir | dir <- includeDirs bi]+ ++ [opt | opt <- ccOptions bi]+ ++ (if withOptimization lbi then ["-O2"] else [])+ flip mapM_ (cSources bi) $ \cfile -> do+ let ofile = targetDir </> cfile `replaceExtension` objExtension+ createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile)+ rawSystemProgramConf verbosity hmakeProgram conf+ (commonCcArgs ++ ["-c", cfile, "-o", ofile])+-}+ -- link:+ info verbosity "Linking..."+ let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension+ -- | cFile <- cSources bi ]+ libFilePath = targetDir </> mkLibName (packageId pkg_descr)+ hObjs = [ targetDir </> dotToSep m <.> objExtension+ | m <- modules ] + unless (null hObjs {-&& null cObjs-}) $ do+ try (removeFile libFilePath) -- first remove library if it exists++ let arVerbosity | verbosity >= deafening = "v"+ | verbosity >= normal = ""+ | otherwise = "c"++ rawSystemProgramConf verbosity arProgram (withPrograms lbi) $+ ["q"++ arVerbosity, libFilePath]+ ++ hObjs+-- ++ cObjs++ withExe pkg_descr $ \exe -> do+ when (dropExtension (modulePath exe) /= exeName exe) $+ die $ "hmake does not support exe names that do not match the name of "+ ++ "the 'main-is' file. You will have to rename your executable to "+ ++ show (dropExtension (modulePath exe))+ let bi = buildInfo exe+ modules = otherModules bi+ -- Unsupported extensions have already been checked by configure+ extensionFlags = extensionsToFlags (compiler lbi) (extensions bi)+ inFiles <- getModulePaths lbi bi modules+ let targetDir = buildDir lbi </> exeName exe+ exeDir = targetDir </> (exeName exe ++ "-tmp")+ srcDirs = nub (map takeDirectory (modulePath exe : inFiles))+ destDirs = map (exeDir </>) srcDirs+ mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs+ rawSystemProgramConf verbosity hmakeProgram conf $+ ["-hc=" ++ programPath nhcProg]+ ++ nhcVerbosityOptions verbosity+ ++ ["-d", targetDir, "-hidir", targetDir]+ ++ extensionFlags+ ++ maybe [] (hcOptions NHC . libBuildInfo)+ (library pkg_descr)+ ++ concat [ ["-package", packageName pkg] | pkg <- packageDeps lbi ]+ ++ inFiles+ ++ [exeName exe]++nhcVerbosityOptions :: Verbosity -> [String]+nhcVerbosityOptions verbosity+ | verbosity >= deafening = ["-v"]+ | verbosity >= normal = []+ | otherwise = ["-q"]++--TODO: where to put this? it's duplicated in .Simple too+getModulePaths :: LocalBuildInfo -> BuildInfo -> [String] -> IO [FilePath]+getModulePaths lbi bi modules = sequence+ [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi)+ (dotToSep module_) >>= maybe (notFound module_) (return . normalise)+ | module_ <- modules ]+ where notFound module_ = die $ "can't find source for module " ++ module_++-- -----------------------------------------------------------------------------+-- Installing++-- |Install executables for GHC.+installExe :: Verbosity -- ^verbosity+ -> FilePath -- ^install location+ -> FilePath -- ^Build location+ -> (FilePath, FilePath) -- ^Executable (prefix,suffix)+ -> Executable+ -> IO ()+installExe verbosity pref buildPref (progprefix,progsuffix) exe+ = do createDirectoryIfMissingVerbose verbosity True pref+ let exeBaseName = exeName exe+ exeFileName = exeBaseName <.> exeExtension+ fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension+ copyFileVerbose verbosity (buildPref </> exeBaseName </> exeFileName)+ (pref </> fixedExeFileName)++-- |Install for nhc98: .hi and .a files+installLib :: Verbosity -- ^verbosity+ -> FilePath -- ^install location+ -> FilePath -- ^Build location+ -> PackageIdentifier+ -> Library+ -> IO ()+installLib verbosity pref buildPref pkgid lib+ = do let bi = libBuildInfo lib+ modules = exposedModules lib ++ otherModules bi+ smartCopySources verbosity [buildPref] pref modules ["hi"]+ let libName = mkLibName pkgid+ copyFileVerbose verbosity (buildPref </> libName) (pref </> libName)
+ Distribution/Simple/PackageIndex.hs view
@@ -0,0 +1,464 @@+{-# 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.Simple.PackageIndex+-- Copyright : (c) David Himmelstrup 2005,+-- Bjorn Bringert 2007,+-- Duncan Coutts 2008+-- License : BSD-like+--+-- Maintainer : Duncan Coutts <duncan@haskell.org>+-- Stability : provisional+-- Portability : portable+--+-- An index of packages.+-----------------------------------------------------------------------------+module Distribution.Simple.PackageIndex (+ -- * Package index data type+ PackageIndex,++ -- * Creating an index+ fromList,++ -- * Updates+ merge,+ insert,+ deletePackageName,+ deletePackageId,+ deleteDependency,++ -- * Queries++ -- ** Precise lookups+ lookupPackageName,+ lookupPackageId,+ lookupDependency,++ -- ** Case-insensitive searches+ searchByName,+ SearchResult(..),+ searchByNameSubstring,++ -- ** Bulk queries+ allPackages,+ allPackagesByName,++ -- ** Special queries+ brokenPackages,+ dependencyClosure,+ reverseDependencyClosure,+ dependencyInconsistencies,+ dependencyCycles,+ dependencyGraph,+ ) where++import Prelude hiding (lookup)+import Control.Exception (assert)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Tree as Tree+import qualified Data.Graph as Graph+import qualified Data.Array as Array+import Data.Array ((!))+import Data.List (groupBy, sortBy, find)+import Data.Monoid (Monoid(..))+import Data.Maybe (isNothing, fromMaybe)++import Distribution.Package+ ( PackageIdentifier, Package(..), packageName, packageVersion+ , Dependency(Dependency), PackageFixedDeps(..) )+import Distribution.Version+ ( Version, withinRange )+import Distribution.Simple.Utils (lowercase, equating, comparing, isInfixOf)++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)+import Text.Read+import qualified Text.Read.Lex as L+#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.+ --+ -- 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.+ --+ (Map String [pkg])++#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)+ deriving (Show, Read)+#else+-- The Show/Read instance for Data.Map in ghc-6.4 is useless+-- so we have to re-implement it here:+instance (Package pkg, Show pkg) => Show (PackageIndex pkg) where+ showsPrec d (PackageIndex m) =+ showParen (d > 10) (showString "PackageIndex" . shows (Map.toList m))++instance (Package pkg, Read pkg) => Read (PackageIndex pkg) where+ readPrec = parens $ prec 10 $ do+ Ident "PackageIndex" <- lexP+ xs <- readPrec+ return (PackageIndex (Map.fromList xs))+ where parens :: ReadPrec a -> ReadPrec a+ parens p = optional+ where+ optional = p +++ mandatory+ mandatory = paren optional++ paren :: ReadPrec a -> ReadPrec a+ paren p = do L.Punc "(" <- lexP+ x <- reset p+ L.Punc ")" <- lexP+ return x++ readListPrec = readListPrecDefault+#endif++instance Package pkg => Monoid (PackageIndex pkg) where+ mempty = PackageIndex (Map.empty)+ mappend = merge+ --save one mappend with empty in the common case:+ mconcat [] = mempty+ mconcat xs = foldr1 mappend xs++invariant :: Package pkg => PackageIndex pkg -> Bool+invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)+ where+ 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+ && pkgid < pkgid'+ && check pkgid' pkgs+ where pkgid' = packageId pkg'++mkPackageIndex :: Package pkg => Map String [pkg] -> PackageIndex pkg+mkPackageIndex index = assert (invariant (PackageIndex index))+ (PackageIndex index)++internalError :: String -> a+internalError name = error ("PackageIndex." ++ name ++ ": internal error")++-- | Lookup a name in the index to get all packages that match that name+-- case-insensitively.+--+lookup :: Package pkg => PackageIndex pkg -> String -> [pkg]+lookup (PackageIndex m) name =+ case Map.lookup (lowercase name) m of+ Nothing -> []+ Just pkgs -> pkgs++-- | Build an index out of a bunch of 'Package's.+--+-- 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])+ | pkg <- pkgs ]+ where+ fixBucket = -- out of groups of duplicates, later ones mask earlier ones+ -- but Map.fromListWith (++) constructs groups in reverse order+ map head+ -- Eq instance for PackageIdentifier is wrong, so use Ord:+ . groupBy (\a b -> EQ == comparing packageId a b)+ -- relies on sortBy being a stable sort so we+ -- can pick consistently among duplicates+ . sortBy (comparing packageId)++-- | Merge two indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+merge i1@(PackageIndex m1) i2@(PackageIndex m2) =+ assert (invariant i1 && invariant i2) $+ mkPackageIndex (Map.unionWith mergeBuckets m1 m2)++-- | Elements in the second list mask those in the first.+mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]+mergeBuckets [] ys = ys+mergeBuckets xs [] = xs+mergeBuckets xs@(x:xs') ys@(y:ys') =+ case packageId x `compare` packageId y of+ GT -> y : mergeBuckets xs ys'+ EQ -> y : mergeBuckets xs' ys'+ LT -> x : mergeBuckets xs' ys++-- | Inserts a single package into the index.+--+-- This is equivalent to (but slightly quicker than) using 'mappend' or+-- 'merge' with a singleton index.+--+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+ where+ pkgid = packageId pkg+ insertNoDup [] = [pkg]+ insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+ LT -> pkg : pkgs+ EQ -> pkg : pkgs'+ GT -> pkg' : insertNoDup pkgs'++-- | Internal delete helper.+--+delete :: Package pkg => String -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg+delete name p (PackageIndex index) = mkPackageIndex $+ let key = lowercase name+ in Map.update filterBucket key index+ where+ filterBucket = deleteEmptyBucket+ . filter (not . p)+ deleteEmptyBucket [] = Nothing+ deleteEmptyBucket remaining = Just remaining++-- | Removes a single package from the index.+--+deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg+deletePackageId pkgid =+ delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)++-- | Removes all packages with this (case-sensitive) name from the index.+--+deletePackageName :: Package pkg => String -> PackageIndex pkg -> PackageIndex pkg+deletePackageName name =+ delete name (\pkg -> packageName pkg == name)++-- | Removes all packages satisfying this dependency from the index.+--+deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg+deleteDependency (Dependency name verstionRange) =+ delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)++-- | Get all the packages from the index.+--+allPackages :: Package pkg => PackageIndex pkg -> [pkg]+allPackages (PackageIndex m) = concat (Map.elems m)++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]+allPackagesByName (PackageIndex m) =+ concatMap (groupBy (equating packageName)) (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.+--+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,+-- then we get back at most one package.+--+lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg+lookupPackageId index pkgid =+ case [ pkg | pkg <- lookup index (packageName pkgid)+ , packageId pkg == pkgid ] of+ [] -> Nothing+ [pkg] -> Just pkg+ _ -> internalError "lookupPackageIdentifier"++-- | Does a case-sensitive search by package name.+--+lookupPackageName :: Package pkg => PackageIndex pkg -> String -> [pkg]+lookupPackageName index name =+ [ pkg | pkg <- lookup index name+ , packageName pkg == name ]++-- | Does a case-sensitive search by package name and a range of versions.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]+lookupDependency index (Dependency name versionRange) =+ [ pkg | pkg <- lookup index name+ , packageName pkg == name+ , packageVersion pkg `withinRange` versionRange ]++-- | All packages that have dependencies that are not in the index.+--+-- Returns such packages along with the dependencies that they're missing.+--+brokenPackages :: PackageFixedDeps pkg+ => PackageIndex pkg+ -> [(pkg, [PackageIdentifier])]+brokenPackages index =+ [ (pkg, missing)+ | pkg <- allPackages index+ , let missing = [ pkg' | pkg' <- depends pkg+ , isNothing (lookupPackageId index pkg') ]+ , not (null missing) ]++-- | Tries to take the transative closure of the package dependencies.+--+-- If the transative closure is complete then it returns that subset of the+-- index. Otherwise it returns the broken packages as in 'brokenPackages'.+--+-- * Note that if the result is @Right []@ it is because at least one of+-- the original given 'PackageIdentifier's do not occur in the index.+--+dependencyClosure :: PackageFixedDeps pkg+ => PackageIndex pkg+ -> [PackageIdentifier]+ -> Either (PackageIndex pkg)+ [(pkg, [PackageIdentifier])]+dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of+ (completed, []) -> Left completed+ (completed, _) -> Right (brokenPackages completed)+ where+ closure completed failed [] = (completed, failed)+ closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of+ Nothing -> closure completed (pkgid:failed) pkgids+ Just pkg -> case lookupPackageId completed (packageId pkg) of+ Just _ -> closure completed failed pkgids+ Nothing -> closure completed' failed pkgids'+ where completed' = insert pkg completed+ pkgids' = depends pkg ++ pkgids++-- | Takes the transative closure of the packages reverse dependencies.+--+-- * The given 'PackageIdentifier's must be in the index.+--+reverseDependencyClosure :: PackageFixedDeps pkg+ => PackageIndex pkg+ -> [PackageIdentifier]+ -> [PackageIdentifier]+reverseDependencyClosure index =+ map vertexToPkgId+ . concatMap Tree.flatten+ . Graph.dfs reverseDepGraph+ . map (fromMaybe noSuchPkgId . pkgIdToVertex)++ where+ (depGraph, vertexToPkgId, pkgIdToVertex) = dependencyGraph index+ reverseDepGraph = Graph.transposeG depGraph+ noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"++-- | 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.+-- Return all cases where multiple packages depend on different versions of+-- some other package.+--+-- Each element in the result is a package name along with the packages that+-- depend on it and the versions they require. These are guaranteed to be+-- distinct.+--+dependencyInconsistencies :: PackageFixedDeps pkg+ => PackageIndex pkg+ -> [(String, [(PackageIdentifier, Version)])]+dependencyInconsistencies index =+ [ (name, inconsistencies)+ | (name, uses) <- Map.toList inverseIndex+ , let inconsistencies = duplicatesBy uses+ , not (null inconsistencies) ]++ where inverseIndex = Map.fromListWith (++)+ [ (packageName dep, [(packageId pkg, packageVersion dep)])+ | pkg <- allPackages index+ , dep <- depends pkg ]++ duplicatesBy = (\groups -> if length groups == 1+ then []+ else concat groups)+ . groupBy (equating snd)+ . sortBy (comparing snd)++-- | Find if there are any cycles in the dependency graph. If there are no+-- cycles the result is @[]@.+--+-- This actually computes the strongly connected components. So it gives us a+-- list of groups of packages where within each group they all depend on each+-- other, directly or indirectly.+--+dependencyCycles :: PackageFixedDeps pkg+ => PackageIndex pkg+ -> [[pkg]]+dependencyCycles index =+ [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+ where+ adjacencyList = [ (pkg, packageId pkg, depends pkg)+ | pkg <- allPackages index ]++-- | Builds a graph of the package dependencies.+--+-- Dependencies on other packages that are 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,+ PackageIdentifier -> Maybe Graph.Vertex)+dependencyGraph index = (graph, vertexToPkgId, pkgIdToVertex)+ where+ graph = Array.listArray bounds+ [ [ v | Just v <- map pkgIdToVertex (depends pkg) ]+ | pkg <- pkgs ]+ vertexToPkgId vertex = pkgIdTable ! vertex+ pkgIdToVertex = binarySearch 0 topBound++ pkgIdTable = Array.listArray bounds (map packageId pkgs)+ pkgs = sortBy (comparing packageId) (allPackages index)+ topBound = length pkgs - 1+ bounds = (0, topBound)++ binarySearch a b key+ | a > b = Nothing+ | otherwise = case compare key (pkgIdTable ! mid) of+ LT -> binarySearch a (mid-1) key+ EQ -> Just mid+ GT -> binarySearch (mid+1) b key+ where mid = (a + b) `div` 2
Distribution/Simple/PreProcess.hs view
@@ -49,7 +49,6 @@ module Distribution.Simple.PreProcess (preprocessSources, knownSuffixHandlers, ppSuffixes, PPSuffixHandler, PreProcessor(..), mkSimplePreProcessor, runSimplePreProcessor,- removePreprocessed, removePreprocessedPackage, ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, ppHappy, ppAlex, ppUnlit )@@ -57,14 +56,19 @@ import Distribution.Simple.PreProcess.Unlit (unlit)-import Distribution.PackageDescription (setupMessage, PackageDescription(..),+import Distribution.PackageDescription (PackageDescription(..), BuildInfo(..), Executable(..), withExe, Library(..), withLib, libModules)-import Distribution.Package (showPackageId)-import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..), compilerVersion)+import Distribution.Package+ ( Package(..) )+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, die,- moduleToFilePath, moduleToFilePath2)+import Distribution.Simple.BuildPaths (autogenModulesDir)+import Distribution.Simple.Utils+ ( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File+ , die, setupMessage, intercalate+ , findFileWithExtension, findFileWithExtension', dotToSep ) import Distribution.Simple.Program (Program(..), ConfiguredProgram(..), lookupProgram, programPath, rawSystemProgramConf, rawSystemProgram,@@ -73,11 +77,12 @@ haddockProgram, ghcProgram) import Distribution.Version (Version(..)) import Distribution.Verbosity+import Distribution.Text+ ( display ) import Control.Monad (when, unless, join) import Data.Maybe (fromMaybe)-import Data.List (nub)-import System.Directory (removeFile, getModificationTime)+import System.Directory (getModificationTime) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (</>), (<.>), takeDirectory, normalise)@@ -166,21 +171,19 @@ preprocessSources pkg_descr lbi forSDist verbosity handlers = do withLib pkg_descr () $ \ lib -> do- setupMessage verbosity "Preprocessing library" pkg_descr+ setupMessage verbosity "Preprocessing library" (packageId pkg_descr) let bi = libBuildInfo lib let biHandlers = localHandlers bi- sequence_ [ preprocessModule (hsSourceDirs bi) (buildDir lbi) forSDist + sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist modu verbosity builtinSuffixes biHandlers | modu <- libModules pkg_descr] unless (null (executables pkg_descr)) $- setupMessage verbosity "Preprocessing executables for" pkg_descr+ setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr) withExe pkg_descr $ \ theExe -> do let bi = buildInfo theExe let biHandlers = localHandlers bi let exeDir = buildDir lbi </> exeName theExe </> exeName theExe ++ "-tmp"- sequence_ [ preprocessModule (nub $ (hsSourceDirs bi)- ++ (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)))- exeDir forSDist+ sequence_ [ preprocessModule (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist modu verbosity builtinSuffixes biHandlers | modu <- otherModules bi] preprocessModule (hsSourceDirs bi) exeDir forSDist@@ -206,15 +209,17 @@ 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 <- moduleToFilePath2 searchLoc modu (map fst handlers)+ psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc (dotToSep modu) case psrcFiles of -- no preprocessor file exists, look for an ordinary source file- [] -> do bsrcFiles <- moduleToFilePath searchLoc modu builtinSuffixes+ Nothing -> do+ bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc (dotToSep modu) case bsrcFiles of- [] -> die ("can't find source for " ++ modu ++ " in " ++ show searchLoc)- _ -> return ()+ Nothing -> die ("can't find source for " ++ modu ++ " in "+ ++ intercalate ", " searchLoc)+ _ -> return () -- found a pre-processable file in one of the source dirs- ((psrcLoc, psrcRelFile):_) -> do+ Just (psrcLoc, psrcRelFile) -> do let (srcStem, ext) = splitExtension psrcRelFile psrcFile = psrcLoc </> psrcRelFile pp = fromMaybe (error "Internal error in preProcess module: Just expected")@@ -230,10 +235,10 @@ 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 <- moduleToFilePath [buildLoc] modu builtinSuffixes+ ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] (dotToSep modu) recomp <- case ppsrcFiles of- [] -> return True- (ppsrcFile:_) -> do+ Nothing -> return True+ Just ppsrcFile -> do btime <- getModificationTime ppsrcFile ptime <- getModificationTime psrcFile return (btime < ptime)@@ -248,33 +253,6 @@ tailNotNull [] = [] tailNotNull x = tail x -removePreprocessedPackage :: PackageDescription- -> FilePath -- ^root of source tree (where to look for hsSources)- -> [String] -- ^suffixes- -> IO ()-removePreprocessedPackage pkg_descr r suff- = do withLib pkg_descr () (\lib -> do- let bi = libBuildInfo lib- removePreprocessed (map (r </>) (hsSourceDirs bi)) (libModules pkg_descr) suff)- withExe pkg_descr (\theExe -> do- let bi = buildInfo theExe- removePreprocessed (map (r </>) (hsSourceDirs bi)) (otherModules bi) suff)---- |Remove the preprocessed .hs files. (do we need to get some .lhs files too?)-removePreprocessed :: [FilePath] -- ^search Location- -> [String] -- ^Modules- -> [String] -- ^suffixes- -> IO ()-removePreprocessed searchLocs mods suffixesIn- = mapM_ removePreprocessedModule mods- where removePreprocessedModule m = do- -- collect related files- fs <- moduleToFilePath searchLocs m otherSuffixes- -- does M.hs also exist?- hs <- moduleToFilePath searchLocs m ["hs"]- unless (null fs) (mapM_ removeFile hs)- otherSuffixes = filter (/= "hs") suffixesIn- -- ------------------------------------------------------------ -- * known preprocessors -- ------------------------------------------------------------@@ -295,8 +273,8 @@ PreProcessor { platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> do- contents <- readFile inFile- writeFile outFile (unlit inFile contents)+ contents <- readUTF8File inFile+ either (writeUTF8File outFile) die (unlit inFile contents) } ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor@@ -371,7 +349,7 @@ ++ cppOptions bi ] ++ [ "--cflag=" ++ opt | pkg <- packageDeps lbi , opt <- ["-package"- ,showPackageId pkg] ]+ ,display pkg] ] ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi] ++ [ "--lflag=-optl" ++ opt | opt <- getLdOptions bi ]
Distribution/Simple/PreProcess/Unlit.hs view
@@ -9,82 +9,158 @@ -- -- Remove the \"literal\" markups from a Haskell source file, including -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"------ Part of the following code is from--- /Report on the Programming Language Haskell/,--- version 1.2, appendix C. -module Distribution.Simple.PreProcess.Unlit(unlit,plain) where+-- This version is interesting because instead of striping comment lines, it+-- turns them into "-- " style comments. This allows using haddock markup+-- in literate scripts without having to use "> --" prefix. +module Distribution.Simple.PreProcess.Unlit (unlit,plain) where+ import Data.Char+import Data.List -data Classified = Program String | Blank | Comment- | Include Int String | Pre String+data Classified = BirdTrack String | Blank String | Ordinary String+ | Line !Int String | CPP String+ | BeginCode | EndCode+ -- output only:+ | Error String | Comment String -plain :: String -> String -> String -- no unliteration+-- | No unliteration.+plain :: String -> String -> String plain _ hs = hs -classify :: [String] -> [Classified]-classify [] = []-classify ("\\begin{code}":rest) = Blank : allProg rest- where allProg [] = [] -- Should give an error message,- -- but I have no good position information.- allProg ("\\end{code}":xs) = Blank : classify xs- allProg (x:xs) = Program x:allProg xs-classify (('>':x):xs) = Program (' ':x) : classify xs-classify (('#':x):xs) = (case words x of- (line:rest) | all isDigit line- -> Include (read line) (unwords rest)- _ -> Pre x- ) : classify xs-classify (x:xs) | all isSpace x = Blank:classify xs-classify (_:xs) = Comment:classify xs+classify :: String -> Classified+classify ('>':s) = BirdTrack s+classify ('#':s) = case tokens s of+ (line:file:_) | all isDigit line+ && length file >= 2+ && head file == '"'+ && last file == '"'+ -> Line (read line) (tail (init file))+ _ -> CPP s+ where tokens = unfoldr $ \str -> case lex str of+ (t@(_:_), str'):_ -> Just (t, str')+ _ -> Nothing+classify ('\\':s)+ | s `isPrefixOf` "begin{code}" = BeginCode+ | s `isPrefixOf` "end{code}" = EndCode+classify s | all isSpace s = Blank s+classify s = Ordinary s -unclassify :: Classified -> String-unclassify (Program s) = s-unclassify (Pre s) = '#':s-unclassify (Include i f) = '#':' ':show i ++ ' ':f-unclassify Blank = ""-unclassify Comment = ""+-- So the weird exception for comment indenting is to make things work with+-- haddock, see classifyAndCheckForBirdTracks below.+unclassify :: Bool -> Classified -> String+unclassify _ (BirdTrack s) = ' ':s+unclassify _ (Blank s) = s+unclassify _ (Ordinary s) = s+unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file+unclassify _ (CPP s) = '#':s+unclassify True (Comment "") = " --"+unclassify True (Comment s) = " -- " ++ s+unclassify False (Comment "") = "--"+unclassify False (Comment s) = "-- " ++ s+unclassify _ _ = internalError -- | 'unlit' takes a filename (for error reports), and transforms the -- given string, to eliminate the literate comments from the program text.-unlit :: FilePath -> String -> String-unlit file lhs = (unlines- . map unclassify- . adjacent file (0::Int) Blank- . classify) (inlines lhs)+unlit :: FilePath -> String -> Either String String+unlit file input =+ let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks+ . inlines+ $ input+ in either (Left . unlines . map (unclassify usesBirdTracks))+ Right+ . checkErrors+ . reclassify+ $ classified --- Third argument is Comment, Blank or Program _-adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified]-adjacent file n y xs- | file `seq` n `seq` y `seq` xs `seq` False = undefined--- Include (# 123 "foo") lines are always OK and are treated as blank--- The change our idea of filename and line number-adjacent _ _ _ (x@(Include i f):xs) = x: adjacent f i Blank xs--- Other preprocessor lines (# ...) are always OK and are treated as blank-adjacent file n _ (x@(Pre _) :xs) = x: adjacent file (n+1) Blank xs--- Program and comment lines can't be adjacent-adjacent file n (Program _) ( Comment :_ ) = error (message file n "program" "comment")-adjacent file n Comment ( (Program _) :_ ) = error (message file n "comment" "program")--- Anything else is fine, and x is an allowable value for the third argument-adjacent file n _ (x :xs) = x: adjacent file (n+1) x xs-adjacent _ _ _ [] = []+ where+ -- So haddock requires comments and code to align, since it treats comments+ -- as following the layout rule. This is a pain for us since bird track+ -- style literate code typically gets indented by two since ">" is replaced+ -- by " " and people usually use one additional space of indent ie+ -- "> then the code". On the other hand we cannot just go and indent all+ -- the comments by two since that does not work for latex style literate+ -- code. So the hacky solution we use here is that if we see any bird track+ -- style code then we'll indent all comments by two, otherwise by none.+ -- Of course this will not work for mixed latex/bird track .lhs files but+ -- nobody does that, it's silly and specifically recommended against in the+ -- H98 unlit spec.+ --+ classifyAndCheckForBirdTracks =+ flip mapAccumL False $ \seenBirdTrack line ->+ let classification = classify line+ in (seenBirdTrack || isBirdTrack classification, classification) -message :: String -> Int -> String -> String -> String-message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"-message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"-message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"+ isBirdTrack (BirdTrack _) = True+ isBirdTrack _ = False + checkErrors ls = case [ e | Error e <- ls ] of+ [] -> Left ls+ (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message)+ where (f, n) = errorPos file 1 ls+ errorPos f n [] = (f, n)+ errorPos f n (Error _:_) = (f, n)+ errorPos _ _ (Line n' f':ls) = errorPos f' n' ls+ errorPos f n (_ :ls) = errorPos f (n+1) ls +-- Here we model a state machine, with each state represented by+-- a local function. We only have four states (well, five,+-- if you count the error state), but the rules+-- to transition between then are not so simple.+-- Would it be simpler to have more states?+--+-- Each state represents the type of line that was last read+-- i.e. are we in a comment section, or a latex-code section,+-- or a bird-code section, etc?+reclassify :: [Classified] -> [Classified]+reclassify = blank -- begin in blank state+ where+ latex [] = []+ latex (EndCode :ls) = Blank "" : comment ls+ latex (BeginCode :_ ) = [Error "\\begin{code} in code section"]+ latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls+ latex ( l:ls) = l : latex ls++ blank [] = []+ blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"]+ blank (BeginCode :ls) = Blank "" : latex ls+ blank (BirdTrack l:ls) = BirdTrack l : bird ls+ blank (Ordinary l:ls) = Comment l : comment ls+ blank ( l:ls) = l : blank ls++ bird [] = []+ bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"]+ bird (BeginCode :ls) = Blank "" : latex ls+ bird (Blank l :ls) = Blank l : blank ls+ bird (Ordinary _:_ ) = [Error "program line before comment line"]+ bird ( l:ls) = l : bird ls++ comment [] = []+ comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"]+ comment (BeginCode :ls) = Blank "" : latex ls+ comment (CPP l :ls) = CPP l : comment ls+ comment (BirdTrack _:_ ) = [Error "comment line before program line"]+ -- a blank line and another ordinary line following a comment+ -- will be treated as continuing the comment. Otherwise it's+ -- then end of the comment, with a blank line.+ comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls+ comment (Blank l:ls) = Blank l : blank ls+ comment (Line n f :ls) = Line n f : comment ls+ comment (Ordinary l:ls) = Comment l : comment ls+ comment (Comment _: _) = internalError+ comment (Error _: _) = internalError+ -- Re-implementation of 'lines', for better efficiency (but decreased laziness). -- Also, importantly, accepts non-standard DOS and Mac line ending characters. inlines :: String -> [String] inlines xs = lines' xs id where lines' [] acc = [acc []]- lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS- lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS- lines' ('\n':s) acc = acc [] : lines' s id -- Unix+ lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS+ lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS+ lines' ('\n':s) acc = acc [] : lines' s id -- Unix lines' (c:s) acc = lines' s (acc . (c:)) +internalError :: a+internalError = error "unlit: internal error"
Distribution/Simple/Program.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program@@ -51,6 +50,7 @@ , userSpecifyPath , userMaybeSpecifyPath , userSpecifyArgs+ , userSpecifiedArgs , lookupProgram , updateProgram , configureAllKnownPrograms@@ -68,6 +68,7 @@ , ffihugsProgram , ranlibProgram , arProgram+ , stripProgram , happyProgram , alexProgram , hsc2hsProgram@@ -79,20 +80,22 @@ , ldProgram , tarProgram , cppProgram- , pfesetupProgram , pkgConfigProgram ) where -import qualified Distribution.Compat.Map as Map-import Distribution.Compat.Directory (findExecutable)-import Distribution.Compat.TempFile (withTempFile)+import qualified Data.Map as Map import Distribution.Simple.Utils (die, debug, warn, rawSystemExit,- rawSystemStdout, rawSystemStdout')-import Distribution.Version (Version(..), readVersion, showVersion,- VersionRange(..), withinRange, showVersionRange)+ rawSystemStdout, rawSystemStdout',+ withTempFile)+import Distribution.Version+ ( Version(..), VersionRange(AnyVersion), withinRange )+import Distribution.Text+ ( simpleParse, display ) import Distribution.Verbosity-import System.Directory (doesFileExist, removeFile)+import System.Directory (doesFileExist, removeFile, findExecutable,+ getTemporaryDirectory) import System.FilePath (dropExtension)+import System.IO (hClose) import System.IO.Error (try) import Control.Monad (join, foldM) import Control.Exception as Exception (catch)@@ -181,11 +184,12 @@ findProgramVersion versionArg selectVersion verbosity path = do str <- rawSystemStdout verbosity path [versionArg] `Exception.catch` \_ -> return ""- let version = readVersion (selectVersion str)+ let version :: Maybe Version+ version = simpleParse (selectVersion str) case version of Nothing -> warn verbosity $ "cannot determine version of " ++ path ++ " :\n" ++ show str- Just v -> debug verbosity $ path ++ " is version " ++ showVersion v+ Just v -> debug verbosity $ path ++ " is version " ++ display v return version -- ------------------------------------------------------------@@ -390,13 +394,13 @@ ++ " is required but it could not be found." badVersion v l = programName prog ++ versionRequirement ++ " is required but the version found at "- ++ locationPath l ++ " is version " ++ showVersion v+ ++ locationPath l ++ " is version " ++ display v noVersion l = programName prog ++ versionRequirement ++ " is required but the version of " ++ locationPath l ++ " could not be determined." versionRequirement | range == AnyVersion = ""- | otherwise = " version " ++ showVersionRange range+ | otherwise = " version " ++ display range -- ------------------------------------------------------------ -- * Running programs@@ -466,10 +470,10 @@ , c2hsProgram , cpphsProgram , greencardProgram- , pfesetupProgram -- platform toolchain , ranlibProgram , arProgram+ , stripProgram , ldProgram , tarProgram -- configuration tools@@ -492,11 +496,20 @@ } nhcProgram :: Program-nhcProgram = simpleProgram "nhc98"+nhcProgram = (simpleProgram "nhc98") {+ programFindVersion = findProgramVersion "--version" $ \str ->+ -- Invoking "nhc98 --version" gives a string like+ -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)"+ case words str of+ (_:('v':ver):_) -> ver+ _ -> ""+ } hmakeProgram :: Program hmakeProgram = (simpleProgram "hmake") { programFindVersion = findProgramVersion "--version" $ \str ->+ -- Invoking "hmake --version" gives a string line+ -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" case words str of (_:ver:_) -> ver _ -> ""@@ -505,6 +518,9 @@ jhcProgram :: Program jhcProgram = (simpleProgram "jhc") { programFindVersion = findProgramVersion "--version" $ \str ->+ -- invoking "jhc --version" gives a string like+ -- "jhc 0.3.20080208 (wubgipkamcep-2)+ -- compiled by ghc-6.8 on a x86_64 running linux" case words str of (_:ver:_) -> ver _ -> ""@@ -544,6 +560,9 @@ arProgram :: Program arProgram = simpleProgram "ar" +stripProgram :: Program+stripProgram = simpleProgram "strip"+ hsc2hsProgram :: Program hsc2hsProgram = (simpleProgram "hsc2hs") { programFindVersion = \verbosity path -> do@@ -561,9 +580,10 @@ -- to see if it was indeed ghc or not. case maybeVersion of Nothing -> return Nothing- Just version ->- withTempFile "dist" "hsc" $ \hsc -> do- writeFile hsc ""+ 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@@ -618,9 +638,6 @@ cppProgram :: Program cppProgram = simpleProgram "cpp"--pfesetupProgram :: Program-pfesetupProgram = simpleProgram "pfesetup" pkgConfigProgram :: Program pkgConfigProgram = (simpleProgram "pkg-config") {
Distribution/Simple/Register.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Register@@ -48,72 +47,56 @@ writeInstalledConfig, removeInstalledConfig, removeRegScripts,-#ifdef DEBUG- hunitTests, installedPkgConfigFile-#endif ) where -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604-#if __GLASGOW_HASKELL__ < 603-#include "config.h"-#else-#include "ghcconfig.h"-#endif-#endif--import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), distPref,+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), InstallDirs(..),- haddockinterfacedir, haddockdir,- InstallDirTemplates(..),- absoluteInstallDirs, toPathTemplate)-import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..),- compilerVersion, PackageDB(..))+ absoluteInstallDirs)+import Distribution.Simple.BuildPaths (haddockName)+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) import Distribution.Simple.Program (ConfiguredProgram, programPath, programArgs, rawSystemProgram, lookupProgram, ghcPkgProgram)-import Distribution.Simple.Setup (RegisterFlags(..), CopyDest(..))-import Distribution.PackageDescription (setupMessage, PackageDescription(..),- BuildInfo(..), Library(..), haddockName)-import Distribution.Package (PackageIdentifier(..), showPackageId)-import Distribution.Version (Version(..))-import Distribution.Verbosity+import Distribution.Simple.Setup+ ( RegisterFlags(..), CopyDest(..)+ , fromFlag, fromFlagOrDefault, flagToMaybe )+import Distribution.PackageDescription (PackageDescription(..),+ BuildInfo(..), Library(..))+import Distribution.Package+ ( Package(..), packageName ) import Distribution.InstalledPackageInfo (InstalledPackageInfo, showInstalledPackageInfo, emptyInstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,- copyFileVerbose, die, info)-import Distribution.Simple.GHC.PackageConfig (mkGHCPackageConfig, showGHCPackageConfig)-import qualified Distribution.Simple.GHC.PackageConfig- as GHC (localPackageConfig, canWriteLocalPackageConfig, maybeCreateLocalPackageConfig)+import Distribution.Simple.Utils+ ( createDirectoryIfMissingVerbose, copyFileVerbose+ , die, info, notice, setupMessage ) import Distribution.System-import Distribution.Compat.Directory- (removeDirectoryRecursive,- setPermissions, getPermissions, Permissions(executable)- )+ ( OS(..), buildOS )+import Distribution.Text+ ( display ) import System.FilePath ((</>), (<.>), isAbsolute)--import System.Directory( removeFile, getCurrentDirectory)+import System.Directory (removeFile, getCurrentDirectory,+ removeDirectoryRecursive,+ setPermissions, getPermissions,+ Permissions(executable)) import System.IO.Error (try) import Control.Monad (when)-import Data.Maybe (isNothing, fromJust, fromMaybe)+import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.List (partition) -#ifdef DEBUG-import Test.HUnit (Test)-#endif- regScriptLocation :: FilePath-regScriptLocation = case os of- Windows _ -> "register.bat"- _ -> "register.sh"+regScriptLocation = case buildOS of+ Windows -> "register.bat"+ _ -> "register.sh" unregScriptLocation :: FilePath-unregScriptLocation = case os of- Windows _ -> "unregister.bat"- _ -> "unregister.sh"+unregScriptLocation = case buildOS of+ Windows -> "unregister.bat"+ _ -> "unregister.sh" -- ----------------------------------------------------------------------------- -- Registration@@ -123,60 +106,45 @@ -> IO () register pkg_descr lbi regFlags | isNothing (library pkg_descr) = do- setupMessage (regVerbose regFlags) "No package to register" pkg_descr+ setupMessage (fromFlag $ regVerbosity regFlags) "No package to register" (packageId pkg_descr) return () | otherwise = do- let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] []- isWindows = case os of Windows _ -> True; _ -> False- genScript = regGenScript regFlags- genPkgConf = regGenPkgConf regFlags- genPkgConfigDefault = showPackageId (package pkg_descr) <.> "conf"+ let distPref = fromFlag $ regDistPref regFlags+ isWindows = case buildOS of Windows -> True; _ -> False+ genScript = fromFlag (regGenScript regFlags)+ genPkgConf = isJust (flagToMaybe (regGenPkgConf regFlags))+ genPkgConfigDefault = display (packageId pkg_descr) <.> "conf" genPkgConfigFile = fromMaybe genPkgConfigDefault- (regPkgConfFile regFlags)- verbosity = regVerbose regFlags- packageDB = fromMaybe (withPackageDB lbi) (regPackageDB regFlags)- inplace = regInPlace regFlags+ (fromFlag (regGenPkgConf regFlags))+ verbosity = fromFlag (regVerbosity regFlags)+ packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)+ inplace = fromFlag (regInPlace regFlags) message | genPkgConf = "Writing package registration file: " ++ genPkgConfigFile ++ " for" | genScript = "Writing registration script: " ++ regScriptLocation ++ " for" | otherwise = "Registering"- setupMessage (regVerbose regFlags) message pkg_descr+ setupMessage verbosity message (packageId pkg_descr) case compilerFlavor (compiler lbi) of GHC -> do config_flags <- case packageDB of- GlobalPackageDB -> return []- UserPackageDB- | ghc_63_plus -> return ["--user"]- | otherwise -> do- GHC.maybeCreateLocalPackageConfig- localConf <- GHC.localPackageConfig- pkgConfWriteable <- GHC.canWriteLocalPackageConfig- when (not pkgConfWriteable && not genScript)- $ userPkgConfErr localConf- return ["--config-file=" ++ localConf]- SpecificPackageDB db- | ghc_63_plus -> return ["-package-conf", db]- | otherwise -> return ["--config-file=" ++ db]+ GlobalPackageDB -> return []+ UserPackageDB -> return ["--user"]+ SpecificPackageDB db -> return ["--package-conf=" ++ db] let instConf | genPkgConf = genPkgConfigFile- | inplace = inplacePkgConfigFile- | otherwise = installedPkgConfigFile+ | inplace = inplacePkgConfigFile distPref+ | otherwise = installedPkgConfigFile distPref when (genPkgConf || not genScript) $ do info verbosity ("create " ++ instConf)- writeInstalledConfig pkg_descr lbi inplace (Just instConf)+ writeInstalledConfig distPref pkg_descr lbi inplace (Just instConf) - let register_flags- | ghc_63_plus = let conf = if genScript && not isWindows+ let register_flags = let conf = if genScript && not isWindows then ["-"] else [instConf] in "update" : conf- | otherwise = let conf = if genScript && not isWindows- then []- else ["--input-file="++instConf]- in "--update-package" : conf let allFlags = config_flags ++ register_flags let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)@@ -184,7 +152,7 @@ case () of _ | genPkgConf -> return () | genScript ->- do cfg <- showInstalledConfig pkg_descr lbi inplace+ do cfg <- showInstalledConfig distPref pkg_descr lbi inplace rawSystemPipe pkgTool regScriptLocation cfg allFlags _ -> rawSystemProgram verbosity pkgTool allFlags @@ -192,51 +160,37 @@ when inplace $ die "--inplace is not supported with Hugs" let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest createDirectoryIfMissingVerbose verbosity True (libdir installDirs)- copyFileVerbose verbosity installedPkgConfigFile+ copyFileVerbose verbosity (installedPkgConfigFile distPref) (libdir installDirs </> "package.conf")- JHC -> when (verbosity >= normal) $ putStrLn "registering for JHC (nothing to do)"- NHC -> when (verbosity >= normal) $ putStrLn "registering nhc98 (nothing to do)"- _ -> die ("only registering with GHC/Hugs/jhc/nhc98 is implemented")--userPkgConfErr :: String -> IO a-userPkgConfErr local_conf = - die ("--user flag passed, but cannot write to local package config: "- ++ local_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" -- ----------------------------------------------------------------------------- -- The installed package config -- |Register doesn't drop the register info file, it must be done in a -- separate step.-writeInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool- -> Maybe FilePath -> IO ()-writeInstalledConfig pkg_descr lbi inplace instConfOverride = do- pkg_config <- showInstalledConfig pkg_descr lbi inplace- let instConfDefault | inplace = inplacePkgConfigFile- | otherwise = installedPkgConfigFile+writeInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo+ -> Bool -> Maybe FilePath -> IO ()+writeInstalledConfig distPref pkg_descr lbi inplace instConfOverride = do+ pkg_config <- showInstalledConfig distPref pkg_descr lbi inplace+ let instConfDefault | inplace = inplacePkgConfigFile distPref+ | otherwise = installedPkgConfigFile distPref instConf = fromMaybe instConfDefault instConfOverride writeFile instConf (pkg_config ++ "\n") -- |Create a string suitable for writing out to the package config file-showInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool+showInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo -> Bool -> IO String-showInstalledConfig pkg_descr lbi inplace- | (case compilerFlavor hc of GHC -> True; _ -> False) &&- compilerVersion hc < Version [6,3] [] - = if inplace then- error "--inplace not supported for GHC < 6.3"- else- return (showGHCPackageConfig (mkGHCPackageConfig pkg_descr lbi))- | otherwise - = do cfg <- mkInstalledPackageInfo pkg_descr lbi inplace+showInstalledConfig distPref pkg_descr lbi inplace+ = do cfg <- mkInstalledPackageInfo distPref pkg_descr lbi inplace return (showInstalledPackageInfo cfg)- where- hc = compiler lbi -removeInstalledConfig :: IO ()-removeInstalledConfig = do- try $ removeFile installedPkgConfigFile- try $ removeFile inplacePkgConfigFile+removeInstalledConfig :: FilePath -> IO ()+removeInstalledConfig distPref = do+ try $ removeFile $ installedPkgConfigFile distPref+ try $ removeFile $ inplacePkgConfigFile distPref return () removeRegScripts :: IO ()@@ -245,51 +199,53 @@ try $ removeFile unregScriptLocation return () -installedPkgConfigFile :: FilePath-installedPkgConfigFile = distPref </> "installed-pkg-config"+installedPkgConfigFile :: FilePath -> FilePath+installedPkgConfigFile distPref = distPref </> "installed-pkg-config" -inplacePkgConfigFile :: FilePath-inplacePkgConfigFile = distPref </> "inplace-pkg-config"+inplacePkgConfigFile :: FilePath -> FilePath+inplacePkgConfigFile distPref = distPref </> "inplace-pkg-config" -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo mkInstalledPackageInfo- :: PackageDescription+ :: FilePath+ -> PackageDescription -> LocalBuildInfo -> Bool -> IO InstalledPackageInfo-mkInstalledPackageInfo pkg_descr lbi inplace = do +mkInstalledPackageInfo distPref pkg_descr lbi inplace = do pwd <- getCurrentDirectory let lib = fromJust (library pkg_descr) -- checked for Nothing earlier bi = libBuildInfo lib build_dir = pwd </> buildDir lbi installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest- inplaceDirs = absoluteInstallDirs pkg_descr lbi {- installDirTemplates = (installDirTemplates lbi) {- dataDirTemplate = toPathTemplate pwd,- dataSubdirTemplate = toPathTemplate distPref,- docDirTemplate = toPathTemplate (pwd </> distPref </> "doc"),- htmlDirTemplate = toPathTemplate (pwd </> distPref </> "doc" </> "html" </> pkgName (package pkg_descr)),- interfaceDirTemplate = toPathTemplate (pwd </> distPref </> "doc" </> "html" </> pkgName (package pkg_descr))- }- } 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 (absinc,relinc) = partition isAbsolute (includeDirs bi) installIncludeDir | null (installIncludes bi) = [] | otherwise = [includedir installDirs] haddockInterfaceDir- | inplace = haddockinterfacedir inplaceDirs pkg_descr- | otherwise = haddockinterfacedir installDirs pkg_descr- haddockDir- | inplace = haddockdir inplaceDirs pkg_descr- | otherwise = haddockdir installDirs pkg_descr+ | inplace = haddockdir inplaceDirs+ | otherwise = haddockdir installDirs+ haddockHtmlDir+ | inplace = htmldir inplaceDirs+ | otherwise = htmldir installDirs libraryDir | inplace = build_dir | otherwise = libdir installDirs in return emptyInstalledPackageInfo{- IPI.package = package pkg_descr,+ IPI.package = packageId pkg_descr, IPI.license = license pkg_descr, IPI.copyright = copyright pkg_descr, IPI.maintainer = maintainer pkg_descr,@@ -304,7 +260,7 @@ IPI.hiddenModules = otherModules bi, IPI.importDirs = [libraryDir], IPI.libraryDirs = libraryDir : extraLibDirs bi,- IPI.hsLibraries = ["HS" ++ showPackageId (package pkg_descr)],+ IPI.hsLibraries = ["HS" ++ display (packageId pkg_descr)], IPI.extraLibraries = extraLibs bi, IPI.includeDirs = absinc ++ if inplace then map (pwd </>) relinc@@ -317,7 +273,7 @@ IPI.frameworkDirs = [], IPI.frameworks = frameworks bi, IPI.haddockInterfaces = [haddockInterfaceDir </> haddockName pkg_descr],- IPI.haddockHTMLs = [haddockDir]+ IPI.haddockHTMLs = [haddockHtmlDir] } -- -----------------------------------------------------------------------------@@ -325,32 +281,19 @@ unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg_descr lbi regFlags = do- setupMessage (regVerbose regFlags) "Unregistering" pkg_descr- let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] []- genScript = regGenScript regFlags- verbosity = regVerbose regFlags- packageDB = fromMaybe (withPackageDB lbi) (regPackageDB regFlags)+ let genScript = fromFlag (regGenScript regFlags)+ verbosity = fromFlag (regVerbosity regFlags)+ packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags) installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest+ setupMessage verbosity "Unregistering" (packageId pkg_descr) case compilerFlavor (compiler lbi) of GHC -> do config_flags <- case packageDB of- GlobalPackageDB -> return []- UserPackageDB- | ghc_63_plus -> return ["--user"]- | otherwise -> do- GHC.maybeCreateLocalPackageConfig- localConf <- GHC.localPackageConfig- pkgConfWriteable <- GHC.canWriteLocalPackageConfig- when (not pkgConfWriteable && not genScript)- $ userPkgConfErr localConf- return ["--config-file=" ++ localConf]- SpecificPackageDB db- | ghc_63_plus -> return ["-package-conf", db]- | otherwise -> return ["--config-file=" ++ db]+ GlobalPackageDB -> return []+ UserPackageDB -> return ["--user"]+ SpecificPackageDB db -> return ["--package-conf=" ++ db] - let removeCmd = if ghc_63_plus- then ["unregister",showPackageId (package pkg_descr)]- else ["--remove-package="++(pkgName $ package pkg_descr)]+ let removeCmd = ["unregister", display (packageId pkg_descr)] let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) allArgs = removeCmd ++ config_flags if genScript@@ -372,8 +315,8 @@ -> [String] -- ^Args -> IO () rawSystemEmit prog scriptName extraArgs- = case os of- Windows _ ->+ = case buildOS of+ Windows -> writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) _ -> do writeFile scriptName ("#!/bin/sh\n\n" ++ (path ++ concatMap (' ':) args)@@ -390,8 +333,8 @@ -> [String] -- ^Args -> IO () rawSystemPipe prog scriptName pipeFrom extraArgs- = case os of- Windows _ ->+ = case buildOS of+ Windows -> writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) _ -> do writeFile scriptName ("#!/bin/sh\n\n" ++ "echo '" ++ escapeForShell pipeFrom@@ -405,12 +348,3 @@ escapeForShell (c :cs) = c : escapeForShell cs args = programArgs prog ++ extraArgs path = programPath prog---- --------------------------------------------------------------- * Testing--- --------------------------------------------------------------#ifdef DEBUG-hunitTests :: [Test]-hunitTests = []-#endif
Distribution/Simple/Setup.hs view
@@ -1,1031 +1,1434 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- Module : Distribution.Simple.Setup--- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- Stability : alpha--- Portability : portable------ Explanation: Data types and parser for the standard command-line--- setup. Will also return commands it doesn't know about.--{- 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.Simple.Setup (--parseArgs,- module Distribution.Simple.Compiler,- Action(..),- ConfigFlags(..), emptyConfigFlags, configureArgs,- CopyFlags(..), CopyDest(..), emptyCopyFlags,- InstallFlags(..), emptyInstallFlags,- HaddockFlags(..), emptyHaddockFlags,- HscolourFlags(..), emptyHscolourFlags,- BuildFlags(..), emptyBuildFlags,- CleanFlags(..), emptyCleanFlags,- PFEFlags(..),- MakefileFlags(..), emptyMakefileFlags,- RegisterFlags(..), emptyRegisterFlags,- SDistFlags(..),- --optionHelpString,-#ifdef DEBUG- hunitTests,-#endif- parseGlobalArgs,- parseConfigureArgs, parseBuildArgs, parseCleanArgs,- parseMakefileArgs,- parseHscolourArgs, parseHaddockArgs, parseProgramaticaArgs, parseTestArgs,- parseInstallArgs, parseSDistArgs, parseRegisterArgs,- parseUnregisterArgs, parseCopyArgs,- reqPathArg, reqDirArg- ) where----- Misc:-#ifdef DEBUG-import Test.HUnit (Test(..))-#endif--import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..),- defaultCompilerFlavor, PackageDB(..))-import Distribution.Simple.Utils (die, wrapText)-import Distribution.Simple.Program (Program(..), ProgramConfiguration,- knownPrograms, userSpecifyPath, userSpecifyArgs)-import Data.List (find, sort)-import Data.Char( toLower, isSpace )-import Distribution.GetOpt-import Distribution.Verbosity-import System.Exit-import System.Environment---- type CommandLineOpts = (Action,--- [String]) -- The un-parsed remainder--data Action = ConfigCmd ConfigFlags -- config- | BuildCmd -- build- | CleanCmd -- clean- | CopyCmd CopyDest -- copy (--destdir flag)- | HscolourCmd -- hscolour- | HaddockCmd -- haddock- | ProgramaticaCmd -- pfesetup- | InstallCmd -- install (install-prefix)- | SDistCmd -- sdist- | MakefileCmd -- makefile- | TestCmd -- test- | RegisterCmd -- register- | UnregisterCmd -- unregister- | HelpCmd -- help--- | NoCmd -- error case, help case.--- | BDist -- 1.0- deriving Show---- --------------------------------------------------------------- * Flag-related types--- ---------------------------------------------------------------- | Flags to @configure@ command-data ConfigFlags = ConfigFlags {- configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run- configHcFlavor :: Maybe CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.- configHcPath :: Maybe FilePath, -- ^given compiler location- configHcPkg :: Maybe FilePath, -- ^given hc-pkg location- configVanillaLib :: Bool, -- ^Enable vanilla library- configProfLib :: Bool, -- ^Enable profiling in the library- configSharedLib :: Bool, -- ^Build shared library- configProfExe :: Bool, -- ^Enable profiling in the executables.- configConfigureArgs :: [String], -- ^Extra arguments to @configure@- configOptimization :: Bool, -- ^Enable optimization.- configPrefix :: Maybe FilePath,- -- ^installation prefix- configBinDir :: Maybe FilePath, - -- ^installation dir for binaries,- configLibDir :: Maybe FilePath, - -- ^installation dir for object code libraries, - configLibSubDir :: Maybe FilePath,- -- ^subdirectory of libdir in which libs are installed- configLibExecDir :: Maybe FilePath,- -- ^installation dir for program executables,- configDataDir :: Maybe FilePath,- -- ^installation dir for read-only arch-independent data,- configDataSubDir :: Maybe FilePath,- -- ^subdirectory of datadir in which data files are installed- configDocDir :: Maybe FilePath,- -- ^installation dir for documentation- configHtmlDir :: Maybe FilePath,- -- ^installation dir for HTML documentation- configInterfaceDir :: Maybe FilePath,- -- ^installation dir for haddock interfaces-- configVerbose :: Verbosity, -- ^verbosity level- configPackageDB:: PackageDB, -- ^ the --user flag?- configGHCiLib :: Bool, -- ^Enable compiling library for GHCi- configSplitObjs :: Bool, -- ^Enable -split-objs with GHC- configConfigurationsFlags :: [(String, Bool)]- }- deriving Show---- |The default configuration of a package, before running configure,--- most things are \"Nothing\", zero, etc.-emptyConfigFlags :: ProgramConfiguration -> ConfigFlags-emptyConfigFlags progConf = ConfigFlags {- configPrograms = progConf,- configHcFlavor = defaultCompilerFlavor,- configHcPath = Nothing,- configHcPkg = Nothing,- configVanillaLib = True,- configProfLib = False,- configSharedLib = False,- configProfExe = False,- configConfigureArgs = [],- configOptimization = True,- configPrefix = Nothing,- configBinDir = Nothing,- configLibDir = Nothing,- configLibSubDir = Nothing,- configLibExecDir = Nothing,- configDataDir = Nothing,- configDataSubDir = Nothing,- configDocDir = Nothing,- configHtmlDir = Nothing,- configInterfaceDir = Nothing,- configVerbose = normal,- configPackageDB = GlobalPackageDB,- configGHCiLib = True,- configSplitObjs = False, -- takes longer, so turn off by default- configConfigurationsFlags = []- }---- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)-data CopyFlags = CopyFlags {copyDest :: CopyDest- ,copyVerbose :: Verbosity}- deriving Show---- |The location prefix for the /copy/ command.-data CopyDest- = NoCopyDest- | CopyTo FilePath- | CopyPrefix FilePath -- DEPRECATED- deriving (Eq, Show)--emptyCopyFlags :: CopyDest -> CopyFlags-emptyCopyFlags mprefix = CopyFlags{ copyDest = mprefix,- copyVerbose = normal }---- | Flags to @install@: (package db, verbosity)-data InstallFlags = InstallFlags {installPackageDB :: Maybe PackageDB- ,installVerbose :: Verbosity}- deriving Show--emptyInstallFlags :: InstallFlags-emptyInstallFlags = InstallFlags{ installPackageDB=Nothing,- installVerbose = normal }---- | Flags to @sdist@: (snapshot, verbosity)-data SDistFlags = SDistFlags {sDistSnapshot :: Bool- ,sDistVerbose :: Verbosity}- deriving Show---- | Flags to @register@ and @unregister@: (user package, gen-script,--- in-place, verbosity)-data RegisterFlags = RegisterFlags { regPackageDB :: Maybe PackageDB- , regGenScript :: Bool- , regGenPkgConf :: Bool- , regPkgConfFile :: Maybe FilePath- , regInPlace :: Bool- , regVerbose :: Verbosity }- deriving Show---emptyRegisterFlags :: RegisterFlags-emptyRegisterFlags = RegisterFlags { regPackageDB = Nothing,- regGenScript = False,- regGenPkgConf = False,- regPkgConfFile = Nothing,- regInPlace = False,- regVerbose = normal }--data HscolourFlags = HscolourFlags {hscolourCSS :: Maybe FilePath- ,hscolourExecutables :: Bool- ,hscolourVerbose :: Verbosity}- deriving Show--emptyHscolourFlags :: HscolourFlags-emptyHscolourFlags = HscolourFlags {hscolourCSS = Nothing- ,hscolourExecutables = False- ,hscolourVerbose = normal}--data HaddockFlags = HaddockFlags {haddockHoogle :: Bool- ,haddockHtmlLocation :: Maybe String- ,haddockExecutables :: Bool- ,haddockCss :: Maybe FilePath- ,haddockHscolour :: Bool- ,haddockHscolourCss :: Maybe FilePath- ,haddockVerbose :: Verbosity}- deriving Show--emptyHaddockFlags :: HaddockFlags-emptyHaddockFlags = HaddockFlags {haddockHoogle = False- ,haddockHtmlLocation = Nothing- ,haddockExecutables = False- ,haddockCss = Nothing- ,haddockHscolour = False- ,haddockHscolourCss = Nothing- ,haddockVerbose = normal}--data CleanFlags = CleanFlags {cleanSaveConf :: Bool- ,cleanVerbose :: Verbosity}- deriving Show-emptyCleanFlags :: CleanFlags-emptyCleanFlags = CleanFlags {cleanSaveConf = False, cleanVerbose = normal}--data BuildFlags = BuildFlags {buildVerbose :: Verbosity,- buildPrograms :: ProgramConfiguration}- deriving Show--emptyBuildFlags :: ProgramConfiguration -> BuildFlags-emptyBuildFlags progs = BuildFlags {buildVerbose = normal,- buildPrograms = progs}--data MakefileFlags = MakefileFlags {makefileVerbose :: Verbosity,- makefileFile :: Maybe FilePath}- deriving Show-emptyMakefileFlags :: MakefileFlags-emptyMakefileFlags = MakefileFlags {makefileVerbose = normal,- makefileFile = Nothing}--data PFEFlags = PFEFlags {pfeVerbose :: Verbosity}- deriving Show---- | All the possible flags-data Flag a = GhcFlag | NhcFlag | HugsFlag | JhcFlag- | WithCompiler FilePath | WithHcPkg FilePath- | WithVanillaLib | WithoutVanillaLib- | WithProfLib | WithoutProfLib- | WithSharedLib | WithoutSharedLib- | WithProfExe | WithoutProfExe- | WithOptimization | WithoutOptimization- | WithGHCiLib | WithoutGHCiLib- | WithSplitObjs | WithoutSplitObjs- | ConfigureOption String-- | Prefix FilePath- | BinDir FilePath- | LibDir FilePath- | LibSubDir FilePath- | LibExecDir FilePath- | DataDir FilePath- | DataSubDir FilePath- | DocDir FilePath- | HtmlDir FilePath- | InterfaceDir FilePath- | ConfigurationsFlags [(String, Bool)]-- | ProgramArgs String String -- program name, arguments- | ProgramArg String String -- program name, single argument- | WithProgram String FilePath -- program name, location-- -- For install, register, and unregister:- | UserFlag | GlobalFlag- -- for register & unregister- | GenScriptFlag- | GetPkgConfFlag (Maybe FilePath)- | InPlaceFlag- -- For copy:- | InstPrefix FilePath- | DestDir FilePath- -- For sdist:- | Snapshot- -- For hscolour:- | HscolourCss FilePath- | HscolourExecutables- -- For haddock:- | HaddockHoogle- | HaddockExecutables- | HaddockCss FilePath- | HaddockHscolour- | HaddockHscolourCss FilePath- | HaddockHtmlLocation String- -- For clean:- | SaveConfigure -- ^don't delete dist\/setup-config during clean- -- For makefile:- | MakefileFile FilePath- -- For everyone:- | HelpFlag- | Verbose Verbosity--- | Version?- | Lift a- deriving (Show, Eq)----- --------------------------------------------------------------- * Mostly parsing functions--- ---------------------------------------------------------------- | Arguments to pass to a @configure@ script, e.g. generated by--- @autoconf@.-configureArgs :: ConfigFlags -> [String]-configureArgs flags- = hc_flag ++- optFlag "with-hc-pkg" configHcPkg ++- optFlag "prefix" configPrefix ++- optFlag "bindir" configBinDir ++- optFlag "libdir" configLibDir ++- optFlag "libexecdir" configLibExecDir ++- optFlag "datadir" configDataDir ++- reverse (configConfigureArgs flags)- where- hc_flag = case (configHcFlavor flags, configHcPath flags) of- (_, Just hc_path) -> ["--with-hc=" ++ hc_path]- (Just hc, Nothing) -> ["--with-hc=" ++ showHC hc]- (Nothing,Nothing) -> []- optFlag name config_field = case config_field flags of- Just p -> ["--" ++ name ++ "=" ++ p]- Nothing -> []-- showHC GHC = "ghc"- showHC NHC = "nhc98"- showHC JHC = "jhc"- showHC Hugs = "hugs"- showHC c = "unknown compiler: " ++ (show c)---cmd_help :: OptDescr (Flag a)-cmd_help = Option "h?" ["help"] (NoArg HelpFlag) "Show this help text"--cmd_verbose :: OptDescr (Flag a)-cmd_verbose = Option "v" ["verbose"] (OptArg (Verbose . flagToVerbosity) "n")- "Control verbosity (n is 0--3, default verbosity level is 1)"---- Do we have any other interesting global flags?-globalOptions :: [OptDescr (Flag a)]-globalOptions = [- cmd_help- ]--liftCustomOpts :: [OptDescr a] -> [OptDescr (Flag a)]-liftCustomOpts flags = [ Option shopt lopt (f adesc) help- | Option shopt lopt adesc help <- flags ]- where f (NoArg x) = NoArg (Lift x)- f (ReqArg g s) = ReqArg (Lift . g) s- f (OptArg g s) = OptArg (Lift . g) s--data Cmd a = Cmd {- cmdName :: String,- cmdHelp :: String, -- Short description- cmdDescription :: String, -- Long description- cmdOptions :: ShowOrParseArgs -> [OptDescr (Flag a)],- cmdAction :: Action- }--data ShowOrParseArgs = ShowArgs | ParseArgs--commandList :: ProgramConfiguration -> [Cmd a]-commandList progConf = [configureCmd progConf, buildCmd progConf, makefileCmd,- cleanCmd, installCmd,- copyCmd, sdistCmd, testCmd,- haddockCmd, hscolourCmd, programaticaCmd,- registerCmd, unregisterCmd]--lookupCommand :: String -> [Cmd a] -> Maybe (Cmd a)-lookupCommand name = find ((==name) . cmdName)--printGlobalHelp :: ProgramConfiguration -> IO ()-printGlobalHelp progConf = - do pname <- getProgName- let syntax_line = "Usage: " ++ pname ++ " [GLOBAL FLAGS]\n or: " ++ pname ++ " COMMAND [FLAGS]\n\nGlobal flags:"- putStrLn (usageInfo syntax_line globalOptions)- putStrLn "Typical steps for installing Cabal packages:"- mapM (\x -> putStrLn $ " " ++ pname ++ " " ++ x)- ["configure", "build", "install"]- putStrLn "\nCommands:"- let maxlen = maximum [ length (cmdName cmd) | cmd <- (commandList progConf) ]- sequence_ [ do putStr " "- putStr (align maxlen (cmdName cmd))- putStr " "- putStrLn (cmdHelp cmd)- | cmd <- (commandList progConf) ]- putStrLn $ "\nFor more information about a command, try '" ++ pname ++ " COMMAND --help'."- putStrLn $ "\nThis Setup program uses the Haskell Cabal Infrastructure."- putStrLn $"See http://www.haskell.org/cabal/ for more information."- where align n str = str ++ replicate (n - length str) ' '--printCmdHelp :: Cmd a -> [OptDescr a] -> IO ()-printCmdHelp cmd opts = do pname <- getProgName- let syntax_line = "Usage: " ++ pname ++ " " ++ cmdName cmd ++ " [FLAGS]\n\nFlags for " ++ cmdName cmd ++ ":"- putStrLn (usageInfo syntax_line (cmdOptions cmd ShowArgs ++ liftCustomOpts opts))- putStr (cmdDescription cmd)--getCmdOpt :: Cmd a -> [OptDescr a] -> [String] -> ([Flag a], [String], [String])-getCmdOpt cmd opts s = (flags, other_opts, errs++errs')- where- (flags, nonopts, other_opts, errs) =- getOpt' RequireOrder (cmdOptions cmd ParseArgs ++ liftCustomOpts opts) s- errs' = ["unexpected argument: " ++ nonopt | nonopt <- nonopts]---- We don't want to use elem, because that imposes Eq a-hasHelpFlag :: [Flag a] -> Bool-hasHelpFlag flags = not . null $ [ () | HelpFlag <- flags ]--parseGlobalArgs :: ProgramConfiguration -> [String] -> IO (Action,[String])-parseGlobalArgs progConf args =- case getOpt' RequireOrder globalOptions args of- (flags, _, _, []) | hasHelpFlag flags -> do- printGlobalHelp progConf- exitWith ExitSuccess- (_, cname:cargs, extra_args, []) -> do- case lookupCommand cname (commandList progConf) of- Just cmd -> return (cmdAction cmd, extra_args ++ cargs)- Nothing -> die $ "Unrecognised command: " ++ cname ++ " (try --help)"- (_, [], _, []) -> die $ "No command given (try --help)"- (_, _, _, errs) -> putErrors errs--configureCmd :: ProgramConfiguration -> Cmd a-configureCmd progConf = Cmd {- cmdName = "configure",- cmdHelp = "Prepare to build the package.",- cmdDescription = programFlagsDescription progConf,- cmdOptions = \showOrParseArgs -> [cmd_help, cmd_verbose,- Option "g" ["ghc"] (NoArg GhcFlag) "compile with GHC",- Option "" ["nhc98"] (NoArg NhcFlag) "compile with NHC",- Option "" ["jhc"] (NoArg JhcFlag) "compile with JHC",- Option "" ["hugs"] (NoArg HugsFlag) "compile with hugs",- Option "w" ["with-compiler"] (reqPathArg WithCompiler)- "give the path to a particular compiler",- Option "" ["with-hc-pkg"] (reqPathArg WithHcPkg)- "give the path to the package tool",- Option "" ["prefix"] (reqDirArg Prefix)- "bake this prefix in preparation of installation",- Option "" ["bindir"] (reqDirArg BinDir)- "installation directory for executables",- Option "" ["libdir"] (reqDirArg LibDir)- "installation directory for libraries",- Option "" ["libsubdir"] (reqDirArg LibSubDir)- "subdirectory of libdir in which libs are installed",- Option "" ["libexecdir"] (reqDirArg LibExecDir)- "installation directory for program executables",- Option "" ["datadir"] (reqDirArg DataDir)- "installation directory for read-only data",- Option "" ["datasubdir"] (reqDirArg DataSubDir)- "subdirectory of datadir in which data files are installed",- Option "" ["docdir"] (reqDirArg DocDir)- "installation directory for documentation",- Option "" ["htmldir"] (reqDirArg HtmlDir)- "installation directory for HTML documentation",- Option "" ["interfacedir"] (reqDirArg InterfaceDir)- "installation directory for haddock interfaces",- Option "" ["enable-library-vanilla"] (NoArg WithVanillaLib)- "Enable vanilla libraries",- Option "" ["disable-library-vanilla"] (NoArg WithoutVanillaLib)- "Disable vanilla libraries",- Option "p" ["enable-library-profiling"] (NoArg WithProfLib)- "Enable library profiling",- Option "" ["disable-library-profiling"] (NoArg WithoutProfLib)- "Disable library profiling",- Option "" ["enable-shared"] (NoArg WithSharedLib)- "Enable shared library",- Option "" ["disable-shared"] (NoArg WithoutSharedLib)- "Disable shared library",- Option "" ["enable-executable-profiling"] (NoArg WithProfExe)- "Enable executable profiling",- Option "" ["disable-executable-profiling"] (NoArg WithoutProfExe)- "Disable executable profiling",- Option "O" ["enable-optimization"] (NoArg WithOptimization)- "Build with optimization",- Option "" ["disable-optimization"] (NoArg WithoutOptimization)- "Build without optimization",- Option "" ["enable-library-for-ghci"] (NoArg WithGHCiLib)- "compile library for use with GHCi",- Option "" ["disable-library-for-ghci"] (NoArg WithoutGHCiLib)- "do not compile libraries for GHCi",- Option "" ["enable-split-objs"] (NoArg WithSplitObjs)- "split library into smaller objects to reduce binary sizes (GHC 6.6+)",- Option "" ["disable-split-objs"] (NoArg WithoutSplitObjs)- "split library into smaller objects to reduce binary sizes (GHC 6.6+)",- Option "" ["configure-option"] (ReqArg ConfigureOption "OPT") "Extra option for configure",- Option "" ["user"] (NoArg UserFlag)- "allow dependencies to be satisfied from the user package database. also implies install --user",- Option "" ["global"] (NoArg GlobalFlag)- "(default) dependencies must be satisfied from the global package database",- Option "f" ["flags"] (reqFlagsArgs ConfigurationsFlags)- "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - ]- ++ programConfigurationPaths progConf showOrParseArgs- ++ programConfigurationOptions progConf showOrParseArgs,- cmdAction = ConfigCmd (emptyConfigFlags progConf)- }--programFlagsDescription :: ProgramConfiguration -> String-programFlagsDescription progConf =- "The flags --with-PROG and --PROG-option(s) can be used with"- ++ " the following programs:"- ++ (concatMap ("\n "++) . wrapText 77 . sort)- [ programName prog | (prog, _) <- knownPrograms progConf ]- ++ "\n"--programConfigurationPaths :: ProgramConfiguration -> ShowOrParseArgs- -> [OptDescr (Flag a)]-programConfigurationPaths progConf args = case args of--- we don't want a verbose help text list so we just show a generic one:- ShowArgs -> [withProgramPath "PROG"]- ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf)- where- withProgramPath :: String -> OptDescr (Flag a)- withProgramPath prog =- Option "" ["with-" ++ prog] (reqPathArg (WithProgram prog))- ("give the path to " ++ prog)--programConfigurationOptions :: ProgramConfiguration -> ShowOrParseArgs- -> [OptDescr (Flag a)]-programConfigurationOptions progConf args = case args of--- we don't want a verbose help text list so we just show a generic one:- ShowArgs -> [programOptions "PROG", programOption "PROG"]- ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf)- ++ map (programOption . programName . fst) (knownPrograms progConf)- where- programOptions :: String -> OptDescr (Flag a)- programOptions prog =- Option "" [prog ++ "-options"] (ReqArg (ProgramArgs prog) "OPTS")- ("give extra options to " ++ prog)-- programOption :: String -> OptDescr (Flag a)- programOption prog =- Option "" [prog ++ "-option"] (ReqArg (ProgramArg prog) "OPT")- ("give an extra option to " ++ prog ++- " (no need to quote options containing spaces)")--reqPathArg :: (FilePath -> a) -> ArgDescr a-reqPathArg constr = ReqArg constr "PATH"--reqDirArg :: (FilePath -> a) -> ArgDescr a-reqDirArg constr = ReqArg constr "DIR"--reqFlagsArgs :: ([(String,Bool)] -> a) -> ArgDescr a-reqFlagsArgs constr = ReqArg (constr . flagList) "FLAGS"--flagList :: String -> [(String, Bool)]-flagList = map tagWithValue . words- where tagWithValue ('-':name) = (map toLower name, False)- tagWithValue name = (map toLower name, True)--parseConfigureArgs :: ProgramConfiguration -> ConfigFlags -> [String] -> [OptDescr a] ->- IO (ConfigFlags, [a], [String])-parseConfigureArgs progConf = parseArgs (configureCmd progConf) updateCfg- where updateCfg t GhcFlag = t { configHcFlavor = Just GHC }- updateCfg t NhcFlag = t { configHcFlavor = Just NHC }- updateCfg t JhcFlag = t { configHcFlavor = Just JHC }- updateCfg t HugsFlag = t { configHcFlavor = Just Hugs }- updateCfg t (WithCompiler path) = t { configHcPath = Just path }- updateCfg t (WithHcPkg path) = t { configHcPkg = Just path }- updateCfg t (ProgramArgs name args) = t { configPrograms = - userSpecifyArgs name- (splitArgs args)- (configPrograms t) }- updateCfg t (ProgramArg name arg) = t { configPrograms =- userSpecifyArgs name [arg]- (configPrograms t) }- updateCfg t (WithProgram name path) = t { configPrograms =- userSpecifyPath- name path- (configPrograms t) }- updateCfg t WithVanillaLib = t { configVanillaLib = True }- updateCfg t WithoutVanillaLib = t { configVanillaLib = False,- configGHCiLib = False }- updateCfg t WithProfLib = t { configProfLib = True }- updateCfg t WithoutProfLib = t { configProfLib = False }- updateCfg t WithSharedLib = t { configSharedLib = True }- updateCfg t WithoutSharedLib = t { configSharedLib = False }- updateCfg t WithProfExe = t { configProfExe = True }- updateCfg t WithoutProfExe = t { configProfExe = False }- updateCfg t WithOptimization = t { configOptimization = True }- updateCfg t WithoutOptimization = t { configOptimization = False }- updateCfg t WithGHCiLib = t { configGHCiLib = True }- updateCfg t WithoutGHCiLib = t { configGHCiLib = False }- updateCfg t (Prefix path) = t { configPrefix = Just path }- updateCfg t (BinDir path) = t { configBinDir = Just path }- updateCfg t (LibDir path) = t { configLibDir = Just path }- updateCfg t (LibSubDir path) = t { configLibSubDir= Just path }- updateCfg t (LibExecDir path) = t { configLibExecDir = Just path }- updateCfg t (DataDir path) = t { configDataDir = Just path }- updateCfg t (DataSubDir path) = t { configDataSubDir = Just path }- updateCfg t (DocDir path) = t { configDocDir = Just path }- updateCfg t (HtmlDir path) = t { configHtmlDir = Just path }- updateCfg t (InterfaceDir path) = t { configInterfaceDir = Just path }- updateCfg t (Verbose n) = t { configVerbose = n }- updateCfg t UserFlag = t { configPackageDB = UserPackageDB }- updateCfg t GlobalFlag = t { configPackageDB = GlobalPackageDB }- updateCfg t WithSplitObjs = t { configSplitObjs = True }- updateCfg t WithoutSplitObjs = t { configSplitObjs = False }- updateCfg t (ConfigurationsFlags fs) = t { configConfigurationsFlags =- fs ++ configConfigurationsFlags t }- updateCfg t (ConfigureOption o) = t { configConfigureArgs = o : configConfigureArgs t }- updateCfg t (Lift _) = t- updateCfg _ _ = error $ "Unexpected flag!"--buildCmd :: ProgramConfiguration -> Cmd a-buildCmd progConf = Cmd {- cmdName = "build",- cmdHelp = "Make this package ready for installation.",- cmdDescription = "", -- This can be a multi-line description- cmdOptions = \showOrParseArgs -> [cmd_help, cmd_verbose]- ++ programConfigurationOptions progConf showOrParseArgs,- cmdAction = BuildCmd- }--parseBuildArgs :: ProgramConfiguration -> BuildFlags -> [String] -> [OptDescr a] -> IO (BuildFlags, [a], [String])-parseBuildArgs progConf = parseArgs (buildCmd progConf) updateArgs- where updateArgs bflags fl =- case fl of- Verbose n -> bflags{buildVerbose=n}- ProgramArgs name args -> bflags{buildPrograms =- userSpecifyArgs name- (splitArgs args)- (buildPrograms bflags)}- ProgramArg name arg -> bflags{buildPrograms =- userSpecifyArgs name [arg]- (buildPrograms bflags)}- _ -> error "Unexpected flag!"--makefileCmd :: Cmd a-makefileCmd = Cmd {- cmdName = "makefile",- cmdHelp = "Perform any necessary makefileing.",- cmdDescription = "", -- This can be a multi-line description- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "f" ["file"] (reqPathArg MakefileFile)- "Filename to use (default: Makefile)."],- cmdAction = MakefileCmd- }--parseMakefileArgs :: MakefileFlags -> [String] -> [OptDescr a] -> IO (MakefileFlags, [a], [String])-parseMakefileArgs = parseArgs makefileCmd updateCfg- where updateCfg mflags fl =- case fl of- Verbose n -> mflags{makefileVerbose=n}- MakefileFile f -> mflags{makefileFile=Just f}- _ -> error "Unexpected flag!"--hscolourCmd :: Cmd a-hscolourCmd = Cmd {- cmdName = "hscolour",- cmdHelp = "Generate HsColour colourised code, in HTML format.",- cmdDescription = "Requires hscolour.\n",- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "" ["executables"] (NoArg HscolourExecutables)- "Run hscolour for Executables targets",- Option "" ["css"] (reqPathArg HscolourCss)- "Use a cascading style sheet"],- cmdAction = HscolourCmd- }--parseHscolourArgs :: HscolourFlags -> [String] -> [OptDescr a] -> IO (HscolourFlags, [a], [String])-parseHscolourArgs = parseArgs hscolourCmd updateCfg- where updateCfg (HscolourFlags css doExe verbosity) fl = case fl of- HscolourCss c -> HscolourFlags (Just c) doExe verbosity- HscolourExecutables -> HscolourFlags css True verbosity- Verbose n -> HscolourFlags css doExe n- _ -> error "Unexpected flag!"--haddockCmd :: Cmd a-haddockCmd = Cmd {- cmdName = "haddock",- cmdHelp = "Generate Haddock HTML documentation.",- cmdDescription = "Requires cpphs and haddock.\n",- cmdOptions = \_ ->- [cmd_help, cmd_verbose,- Option "" ["hoogle"] (NoArg HaddockHoogle)- "Generate a hoogle database",- Option "" ["html-location"] (ReqArg HaddockHtmlLocation "URL")- "Location of HTML documentation for pre-requisite packages",- Option "" ["executables"] (NoArg HaddockExecutables)- "Run haddock for Executables targets",- Option "" ["css"] (reqPathArg HaddockCss)- "Use PATH as the haddock stylesheet",- Option "" ["hyperlink-source"] (NoArg HaddockHscolour)- "Hyperlink the documentation to the source code (using HsColour)",- Option "" ["hscolour-css"] (reqPathArg HaddockHscolourCss)- "Use PATH as the HsColour stylesheet"],- cmdAction = HaddockCmd- }--parseHaddockArgs :: HaddockFlags -> [String] -> [OptDescr a] -> IO (HaddockFlags, [a], [String])-parseHaddockArgs = parseArgs haddockCmd updateCfg- where updateCfg hflags fl = case fl of- HaddockHoogle -> hflags{haddockHoogle = True}- HaddockHtmlLocation s -> hflags{haddockHtmlLocation=Just s}- HaddockExecutables -> hflags{haddockExecutables = True}- HaddockCss h -> hflags{haddockCss = Just h}- HaddockHscolour -> hflags{haddockHscolour = True}- HaddockHscolourCss h -> hflags{haddockHscolourCss = Just h}- Verbose n -> hflags{haddockVerbose = n}- _ -> error "Unexpected flag!"--programaticaCmd :: Cmd a-programaticaCmd = Cmd {- cmdName = "pfe",- cmdHelp = "Generate Programatica Project.",- cmdDescription = "",- cmdOptions = \_ -> [cmd_help, cmd_verbose],- cmdAction = ProgramaticaCmd- }--parseProgramaticaArgs :: [String] -> [OptDescr a] -> IO (PFEFlags, [a], [String])-parseProgramaticaArgs = parseNoArgs programaticaCmd PFEFlags--cleanCmd :: Cmd a-cleanCmd = Cmd {- cmdName = "clean",- cmdHelp = "Clean up after a build.",- cmdDescription = "Removes .hi, .o, preprocessed sources, etc.\n", -- Multi-line!- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "s" ["save-configure"] (NoArg SaveConfigure)- "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure."],- cmdAction = CleanCmd- }--parseCleanArgs :: CleanFlags -> [String] -> [OptDescr a] ->- IO (CleanFlags, [a], [String])-parseCleanArgs = parseArgs cleanCmd updateCfg- where updateCfg (CleanFlags saveConfigure verbosity) fl = case fl of- SaveConfigure -> CleanFlags True verbosity- Verbose n -> CleanFlags saveConfigure n- _ -> error "Unexpected flag!"--installCmd :: Cmd a-installCmd = Cmd {- cmdName = "install",- cmdHelp = "Copy the files into the install locations. Run register.",- cmdDescription = "Unlike the copy command, install calls the register command.\nIf you want to install into a location that is not what was\nspecified in the configure step, use the copy command.\n",- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "" ["install-prefix"] (reqDirArg InstPrefix)- "[DEPRECATED, use copy]",- Option "" ["user"] (NoArg UserFlag)- "upon registration, register this package in the user's local package database",- Option "" ["global"] (NoArg GlobalFlag)- "(default; override with configure) upon registration, register this package in the system-wide package database"- ],- cmdAction = InstallCmd- }--copyCmd :: Cmd a-copyCmd = Cmd {- cmdName = "copy",- cmdHelp = "Copy the files into the install locations.",- cmdDescription = "Does not call register, and allows a prefix at install time\nWithout the --destdir flag, configure determines location.\n",- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "" ["destdir"] (reqDirArg DestDir)- "directory to copy files to, prepended to installation directories",- Option "" ["copy-prefix"] (reqDirArg InstPrefix)- "[DEPRECATED, directory to copy files to instead of prefix]"- ],- cmdAction = CopyCmd NoCopyDest- }--parseCopyArgs :: CopyFlags -> [String] -> [OptDescr a] ->- IO (CopyFlags, [a], [String])-parseCopyArgs = parseArgs copyCmd updateCfg- where updateCfg (CopyFlags copydest verbosity) fl = case fl of- InstPrefix path -> (CopyFlags (CopyPrefix path) verbosity)- DestDir path -> (CopyFlags (CopyTo path) verbosity)- Verbose n -> (CopyFlags copydest n)- _ -> error $ "Unexpected flag!"---parseInstallArgs :: InstallFlags -> [String] -> [OptDescr a] ->- IO (InstallFlags, [a], [String])-parseInstallArgs = parseArgs installCmd updateCfg- where updateCfg (InstallFlags uFlag verbosity) fl = case fl of- InstPrefix _ -> error "--install-prefix is obsolete. Use copy command instead."- UserFlag -> (InstallFlags (Just UserPackageDB) verbosity)- GlobalFlag -> (InstallFlags (Just GlobalPackageDB) verbosity)- Verbose n -> (InstallFlags uFlag n)- _ -> error $ "Unexpected flag!"--sdistCmd :: Cmd a-sdistCmd = Cmd {- cmdName = "sdist",- cmdHelp = "Generate a source distribution file (.tar.gz or .zip).",- cmdDescription = "", -- This can be a multi-line description- cmdOptions = \_ -> [cmd_help,cmd_verbose,- Option "" ["snapshot"] (NoArg Snapshot)- "Produce a snapshot source distribution"- ],- cmdAction = SDistCmd- }--parseSDistArgs :: [String] -> [OptDescr a] -> IO (SDistFlags, [a], [String])-parseSDistArgs = parseArgs sdistCmd updateCfg (SDistFlags False normal)- where updateCfg (SDistFlags snapshot verbosity) fl = case fl of- Snapshot -> (SDistFlags True verbosity)- Verbose n -> (SDistFlags snapshot n)- _ -> error $ "Unexpected flag!"--testCmd :: Cmd a-testCmd = Cmd {- cmdName = "test",- cmdHelp = "Run the test suite, if any (configure with UserHooks).",- cmdDescription = "", -- This can be a multi-line description- cmdOptions = \_ -> [cmd_help,cmd_verbose],- cmdAction = TestCmd- }--parseTestArgs :: [String] -> [OptDescr a] -> IO (Verbosity, [a], [String])-parseTestArgs = parseNoArgs testCmd id--registerCmd :: Cmd a-registerCmd = Cmd {- cmdName = "register",- cmdHelp = "Register this package with the compiler.",- cmdDescription = "", -- This can be a multi-line description- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "" ["user"] (NoArg UserFlag)- "upon registration, register this package in the user's local package database",- Option "" ["global"] (NoArg GlobalFlag)- "(default) upon registration, register this package in the system-wide package database",- Option "" ["inplace"] (NoArg InPlaceFlag)- "register the package in the build location, so it can be used without being installed",- Option "" ["gen-script"] (NoArg GenScriptFlag)- "instead of registering, generate a script to register later",- Option "" ["gen-pkg-config"] (OptArg GetPkgConfFlag "PKG")- "instead of registering, generate a package registration file"- ],- cmdAction = RegisterCmd- }--parseRegisterArgs :: RegisterFlags -> [String] -> [OptDescr a] ->- IO (RegisterFlags, [a], [String])-parseRegisterArgs = parseArgs registerCmd registerUpdateCfg--registerUpdateCfg :: RegisterFlags -> Flag a -> RegisterFlags-registerUpdateCfg reg fl = case fl of- UserFlag -> reg { regPackageDB=Just UserPackageDB }- GlobalFlag -> reg { regPackageDB=Just GlobalPackageDB }- Verbose n -> reg { regVerbose=n }- GenScriptFlag -> reg { regGenScript=True }- GetPkgConfFlag- Nothing -> reg { regGenPkgConf=True }- GetPkgConfFlag- (Just f) -> reg { regGenPkgConf=True,- regPkgConfFile=Just f }- InPlaceFlag -> reg { regInPlace=True }- _ -> error $ "Unexpected flag!"--unregisterCmd :: Cmd a-unregisterCmd = Cmd {- cmdName = "unregister",- cmdHelp = "Unregister this package with the compiler.",- cmdDescription = "", -- This can be a multi-line description- cmdOptions = \_ -> [cmd_help, cmd_verbose,- Option "" ["user"] (NoArg UserFlag)- "unregister this package in the user's local package database",- Option "" ["global"] (NoArg GlobalFlag)- "(default) unregister this package in the system-wide package database",- Option "" ["gen-script"] (NoArg GenScriptFlag)- "Instead of performing the unregister command, generate a script to unregister later"-- ],- cmdAction = UnregisterCmd- }--parseUnregisterArgs :: RegisterFlags -> [String] -> [OptDescr a] ->- IO (RegisterFlags, [a], [String])-parseUnregisterArgs = parseArgs unregisterCmd registerUpdateCfg---- |Helper function for commands with no arguments except for verbosity--- and help.--parseNoArgs :: (Cmd a)- -> (Verbosity -> b) -- Constructor to make this type.- -> [String] -> [OptDescr a]-> IO (b, [a], [String])-parseNoArgs cmd c = parseArgs cmd updateCfg (c normal)- where- updateCfg _ (Verbose n) = c n- updateCfg _ _ = error "Unexpected flag!"---- |Helper function for commands with more options.--parseArgs :: Cmd a -> (cfg -> Flag a -> cfg) -> cfg ->- [String] -> [OptDescr a] -> IO (cfg, [a], [String])-parseArgs cmd updateCfg cfg args customOpts =- case getCmdOpt cmd customOpts args of- (flags, _, []) | hasHelpFlag flags -> do- printCmdHelp cmd customOpts- exitWith ExitSuccess- (flags, args', []) ->- let flags' = filter (not.isLift) flags in- return (foldl updateCfg cfg flags', unliftFlags flags, args')- (_, _, errs) -> putErrors errs- where- isLift (Lift _) = True- isLift _ = False- unliftFlags :: [Flag a] -> [a]- unliftFlags flags = [ fl | Lift fl <- flags ]---- |Helper function to split a string into a list of arguments.--- It's supposed to handle quoted things sensibly, eg:------ > splitArgs "--foo=\"C:\Program Files\Bar\" --baz"--- > = ["--foo=C:\Program Files\Bar", "--baz"]----splitArgs :: String -> [String]-splitArgs = space []- where- space :: String -> String -> [String]- space w [] = word w []- space w ( c :s)- | isSpace c = word w (space [] s)- space w ('"':s) = string w s- space w s = nonstring w s-- string :: String -> String -> [String]- string w [] = word w []- string w ('"':s) = space w s- string w ( c :s) = string (c:w) s-- nonstring :: String -> String -> [String]- nonstring w [] = word w []- nonstring w ('"':s) = string w s- nonstring w ( c :s) = space (c:w) s-- word [] s = s- word w s = reverse w : s--putErrors :: [String] -> IO a-putErrors errs = die $ "Errors:" ++ concat ['\n':err | err <- errs]---#ifdef DEBUG-hunitTests :: [Test]-hunitTests = []--- The test cases kinda have to be rewritten from the ground up... :/---hunitTests =--- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)]--- (flags, commands', unkFlags, ers)--- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]--- in [TestLabel "very basic option parsing" $ TestList [--- "getOpt flags" ~: "failed" ~:--- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag,--- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag]--- ~=? flags,--- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands',--- "getOpt unknown opts" ~: "failed" ~:--- ["--unknown1", "--unknown2"] ~=? unkFlags,--- "getOpt errors" ~: "failed" ~: [] ~=? ers],------ TestLabel "test location of various compilers" $ TestList--- ["configure parsing for prefix and compiler flag" ~: "failed" ~:--- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), []))--- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"])--- | (name, comp) <- m],------ TestLabel "find the package tool" $ TestList--- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~:--- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), []))--- ~=? (parseArgs ["--prefix=/usr/local", "--"++name,--- "--with-compiler=/foo/comp", "configure"])--- | (name, comp) <- m],------ TestLabel "simpler commands" $ TestList--- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag])--- | (flag, flagCmd) <- [("build", BuildCmd),--- ("install", InstallCmd Nothing False),--- ("sdist", SDistCmd),--- ("register", RegisterCmd False)]--- ]--- ]-#endif---{- Testing ideas:- * IO to look for hugs and hugs-pkg (which hugs, etc)- * quickCheck to test permutations of arguments- * what other options can we over-ride with a command-line flag?--}-+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Setup+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Data types and parser for the standard command-line+-- setup. Will also return commands it doesn't know about.++{- 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.Simple.Setup (++ GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,+ ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,+ CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,+ InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,+ HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,+ HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,+ BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand,+ CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand,+ MakefileFlags(..), emptyMakefileFlags, defaultMakefileFlags, makefileCommand,+ RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,+ unregisterCommand,+ SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand,+ TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand,+ CopyDest(..),+ configureArgs, configureOptions,++ defaultDistPref,++ Flag(..),+ toFlag,+ fromFlag,+ fromFlagOrDefault,+ flagToMaybe,+ flagToList,+ boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where++import Distribution.Compiler ()+import Distribution.ReadE+import Distribution.Text (display, Text(parse))+import Distribution.Package ( Dependency(..) )+import Distribution.PackageDescription+ ( FlagName(..), FlagAssignment )+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import qualified Distribution.Simple.Command as Command+import Distribution.Simple.Compiler+ ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)+ , OptimisationLevel(..), flagToOptimisationLevel )+import Distribution.Simple.Utils+ ( wrapLine, lowercase )+import Distribution.Simple.Program (Program(..), ProgramConfiguration,+ knownPrograms)+import Distribution.Simple.InstallDirs+ ( InstallDirs(..), CopyDest(..),+ PathTemplate, toPathTemplate, fromPathTemplate )+import Data.List (sort)+import Data.Char (isSpace)+import Data.Monoid (Monoid(..))+import Distribution.Verbosity++-- XXX Not sure where this should live+defaultDistPref :: FilePath+defaultDistPref = "dist"++-- ------------------------------------------------------------+-- * Flag type+-- ------------------------------------------------------------++-- | All flags are monoids, they come in two flavours:+--+-- 1. list flags eg+--+-- > --ghc-option=foo --ghc-option=bar+--+-- gives us all the values ["foo", "bar"]+--+-- 2. singular value flags, eg:+--+-- > --enable-foo --disable-foo+--+-- gives us Just False+-- So this Flag type is for the latter singular kind of flag.+-- Its monoid instance gives us the behaviour where it starts out as+-- 'NoFlag' and later flags override earlier ones.+--+data Flag a = Flag a | NoFlag deriving (Show, Eq)++instance Functor Flag where+ fmap f (Flag x) = Flag (f x)+ fmap _ NoFlag = NoFlag++instance Monoid (Flag a) where+ mempty = NoFlag+ _ `mappend` f@(Flag _) = f+ f `mappend` NoFlag = f++instance Bounded a => Bounded (Flag a) where+ minBound = toFlag minBound+ maxBound = toFlag maxBound++instance Enum a => Enum (Flag a) where+ fromEnum = fromEnum . fromFlag+ toEnum = toFlag . toEnum+ enumFrom (Flag a) = map toFlag . enumFrom $ a+ enumFrom _ = []+ enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b+ enumFromThen _ _ = []+ enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b+ enumFromTo _ _ = []+ enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c+ enumFromThenTo _ _ _ = []++toFlag :: a -> Flag a+toFlag = Flag++fromFlag :: Flag a -> a+fromFlag (Flag x) = x+fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault"++fromFlagOrDefault :: a -> Flag a -> a+fromFlagOrDefault _ (Flag x) = x+fromFlagOrDefault def NoFlag = def++flagToMaybe :: Flag a -> Maybe a+flagToMaybe (Flag x) = Just x+flagToMaybe NoFlag = Nothing++flagToList :: Flag a -> [a]+flagToList (Flag x) = [x]+flagToList NoFlag = []++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- In fact since individual flags types are monoids and these are just sets of+-- flags then they are also monoids pointwise. This turns out to be really+-- useful. The mempty is the set of empty flags and mappend allows us to+-- override specific flags. For example we can start with default flags and+-- override with the ones we get from a file or the command line, or both.++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags {+ globalVersion :: Flag Bool,+ globalNumericVersion :: Flag Bool+ }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags = GlobalFlags {+ globalVersion = Flag False,+ globalNumericVersion = Flag False+ }++globalCommand :: CommandUI GlobalFlags+globalCommand = makeCommand name shortDesc longDesc defaultGlobalFlags options+ where+ name = ""+ shortDesc = ""+ longDesc = Just $ \pname ->+ "Typical steps for installing Cabal packages:\n"+ ++ unlines [ " " ++ pname ++ " " ++ x+ | x <- ["configure", "build", "install"]]+ ++ "\nFor more information about a command, try '"+ ++ pname ++ " COMMAND --help'."+ ++ "\nThis Setup program uses the Haskell Cabal Infrastructure."+ ++ "\nSee http://www.haskell.org/cabal/ for more information.\n"+ options _ =+ [option ['V'] ["version"]+ "Print version information"+ globalVersion (\v flags -> flags { globalVersion = v })+ trueArg+ ,option [] ["numeric-version"]+ "Print just the version number"+ globalNumericVersion (\v flags -> flags { globalNumericVersion = v })+ trueArg+ ]++emptyGlobalFlags :: GlobalFlags+emptyGlobalFlags = mempty++instance Monoid GlobalFlags where+ mempty = GlobalFlags {+ globalVersion = mempty,+ globalNumericVersion = mempty+ }+ mappend a b = GlobalFlags {+ globalVersion = combine globalVersion,+ globalNumericVersion = combine globalNumericVersion+ }+ where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Config flags+-- ------------------------------------------------------------++-- | Flags to @configure@ command+data ConfigFlags = ConfigFlags {+ --FIXME: the configPrograms is only here to pass info through to configure+ -- because the type of configure is constrained by the UserHooks.+ -- when we change UserHooks next we should pass the initial+ -- ProgramConfiguration directly and not via ConfigFlags+ configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run++ configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths+ configProgramArgs :: [(String, [String])], -- ^user specifed programs args+ configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.+ configHcPath :: Flag FilePath, -- ^given compiler location+ configHcPkg :: Flag FilePath, -- ^given hc-pkg location+ configVanillaLib :: Flag Bool, -- ^Enable vanilla library+ configProfLib :: Flag Bool, -- ^Enable profiling in the library+ configSharedLib :: Flag Bool, -- ^Build shared library+ configProfExe :: Flag Bool, -- ^Enable profiling in the executables.+ configConfigureArgs :: [String], -- ^Extra arguments to @configure@+ configOptimization :: Flag OptimisationLevel, -- ^Enable optimization.+ configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix.+ configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix.+ configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths+ configScratchDir :: Flag FilePath,+ configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries+ 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+ configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi+ configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC+ configStripExes :: Flag Bool, -- ^Enable executable stripping+ configConstraints :: [Dependency], -- ^Additional constraints for+ -- dependencies+ configConfigurationsFlags :: FlagAssignment+ }+ deriving Show++defaultConfigFlags :: ProgramConfiguration -> ConfigFlags+defaultConfigFlags progConf = emptyConfigFlags {+ configPrograms = progConf,+ configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor,+ configVanillaLib = Flag True,+ configProfLib = Flag False,+ configSharedLib = Flag False,+ configProfExe = Flag False,+ configOptimization = Flag NormalOptimisation,+ configProgPrefix = Flag (toPathTemplate ""),+ configProgSuffix = Flag (toPathTemplate ""),+ configDistPref = Flag defaultDistPref,+ configVerbose = normal,+ configVerbosity = Flag normal,+ configUserInstall = Flag False, --TODO: reverse this+ configGHCiLib = Flag True,+ configSplitObjs = Flag False, -- takes longer, so turn off by default+ configStripExes = Flag True+ }++configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags+configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options+ where+ name = "configure"+ shortDesc = "Prepare to build the package."+ longDesc = Just (\_ -> programFlagsDescription progConf)+ defaultFlags = defaultConfigFlags progConf+ options showOrParseArgs = + configureOptions showOrParseArgs+ ++ programConfigurationPaths progConf showOrParseArgs+ configProgramPaths (\v fs -> fs { configProgramPaths = v })+ ++ programConfigurationOptions progConf showOrParseArgs+ configProgramArgs (\v fs -> fs { configProgramArgs = v })+++configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]+configureOptions showOrParseArgs =+ [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v })+ ,optionDistPref configDistPref (\d flags -> flags { configDistPref = d })++ ,option [] ["compiler"] "compiler"+ configHcFlavor (\v flags -> flags { configHcFlavor = v })+ (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC")+ , (Flag NHC, ([] , ["nhc98"]), "compile with NHC")+ , (Flag JHC, ([] , ["jhc"]), "compile with JHC")+ , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")])++ ,option "w" ["with-compiler"]+ "give the path to a particular compiler"+ configHcPath (\v flags -> flags { configHcPath = v })+ (reqArgFlag "PATH")++ ,option "" ["with-hc-pkg"]+ "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"]+ "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 + (\v flags -> flags { configProgPrefix = v })+ (reqPathTemplateArgFlag "PREFIX")++ ,option "" ["program-suffix"]+ "suffix to be applied to installed executables"+ configProgSuffix (\v flags -> flags { configProgSuffix = v } )+ (reqPathTemplateArgFlag "SUFFIX")++ ,option "" ["library-vanilla"]+ "Vanilla libraries"+ configVanillaLib (\v flags -> flags { configVanillaLib = v })+ (boolOpt [] [])++ ,option "p" ["library-profiling"]+ "Library profiling"+ configProfLib (\v flags -> flags { configProfLib = v })+ (boolOpt "p" [])++ ,option "" ["shared"]+ "Shared library"+ configSharedLib (\v flags -> flags { configSharedLib = v })+ (boolOpt [] [])++ ,option "" ["executable-profiling"]+ "Executable profiling"+ configProfExe (\v flags -> flags { configProfExe = v })+ (boolOpt [] [])+ ,multiOption "optimization"+ configOptimization (\v flags -> flags { configOptimization = v })+ [optArg' "n" (Flag . flagToOptimisationLevel)+ (\f -> case f of+ Flag NoOptimisation -> []+ Flag NormalOptimisation -> [Nothing]+ Flag MaximumOptimisation -> [Just "2"]+ _ -> [])+ "O" ("enable-optimization": case showOrParseArgs of+ -- Allow British English spelling:+ ShowArgs -> []; ParseArgs -> ["enable-optimisation"])+ "Build with optimization (n is 0--2, default is 1)",+ noArg (Flag NoOptimisation) []+ ("disable-optimization": case showOrParseArgs of+ -- Allow British English spelling:+ ShowArgs -> []; ParseArgs -> ["disable-optimisation"])+ "Build without optimization"+ ]++ ,option "" ["library-for-ghci"]+ "compile library for use with GHCi"+ configGHCiLib (\v flags -> flags { configGHCiLib = v })+ (boolOpt [] [])++ ,option "" ["split-objs"]+ "split library into smaller objects to reduce binary sizes (GHC 6.6+)"+ configSplitObjs (\v flags -> flags { configSplitObjs = v })+ (boolOpt [] [])++ ,option "" ["executable-stripping"]+ "strip executables upon installation to reduce binary sizes"+ configStripExes (\v flags -> flags { configStripExes = v })+ (boolOpt [] [])++ ,option "" ["configure-option"]+ "Extra option for configure"+ configConfigureArgs (\v flags -> flags { configConfigureArgs = v })+ (reqArg' "OPT" (\x -> [x]) id)++ ,option "" ["user-install"]+ "doing a per-user installation"+ configUserInstall (\v flags -> flags { configUserInstall = v })+ (boolOpt' ([],["user"]) ([], ["global"]))++ ,option "" ["package-db"]+ "Use a specific package database (to satisfy dependencies and register in)"+ configPackageDB (\v flags -> flags { configPackageDB = v })+ (reqArg' "PATH" (Flag . SpecificPackageDB)+ (\f -> case f of+ Flag (SpecificPackageDB db) -> [db]+ _ -> []))++ ,option "f" ["flags"]+ "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."+ configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })+ (reqArg' "FLAGS" readFlagList showFlagList)++ ,option "" ["extra-include-dirs"]+ "A list of directories to search for header files"+ configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v})+ (reqArg' "PATH" (\x -> [x]) id)++ ,option "" ["extra-lib-dirs"]+ "A list of directories to search for external libraries"+ configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})+ (reqArg' "PATH" (\x -> [x]) id)+ ,option "" ["constraint"]+ "A list of additional constraints on the dependencies."+ configConstraints (\v flags -> flags { configConstraints = v})+ (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))+ (map (\x -> display x)))+ ]+ 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)})++ reqPathTemplateArgFlag title _sf _lf d get set = reqArgFlag title _sf _lf d+ (fmap fromPathTemplate.get)+ (\v flags -> set (fmap toPathTemplate v) flags)++emptyConfigFlags :: ConfigFlags+emptyConfigFlags = mempty++instance Monoid ConfigFlags where+ mempty = ConfigFlags {+ configPrograms = error "FIXME: remove configPrograms",+ configProgramPaths = mempty,+ configProgramArgs = mempty,+ configHcFlavor = mempty,+ configHcPath = mempty,+ configHcPkg = mempty,+ configVanillaLib = mempty,+ configProfLib = mempty,+ configSharedLib = mempty,+ configProfExe = mempty,+ configConfigureArgs = mempty,+ configOptimization = mempty,+ configProgPrefix = mempty,+ configProgSuffix = mempty,+ configInstallDirs = mempty,+ configScratchDir = mempty,+ configDistPref = mempty,+ configVerbose = normal,+ configVerbosity = mempty,+ configUserInstall = mempty,+ configPackageDB = mempty,+ configGHCiLib = mempty,+ configSplitObjs = mempty,+ configStripExes = mempty,+ configExtraLibDirs = mempty,+ configConstraints = mempty,+ configExtraIncludeDirs = mempty,+ configConfigurationsFlags = mempty+ }+ mappend a b = ConfigFlags {+ configPrograms = configPrograms a,+ configProgramPaths = combine configProgramPaths,+ configProgramArgs = combine configProgramArgs,+ configHcFlavor = combine configHcFlavor,+ configHcPath = combine configHcPath,+ configHcPkg = combine configHcPkg,+ configVanillaLib = combine configVanillaLib,+ configProfLib = combine configProfLib,+ configSharedLib = combine configSharedLib,+ configProfExe = combine configProfExe,+ configConfigureArgs = combine configConfigureArgs,+ configOptimization = combine configOptimization,+ configProgPrefix = combine configProgPrefix,+ configProgSuffix = combine configProgSuffix,+ configInstallDirs = combine configInstallDirs,+ configScratchDir = combine configScratchDir,+ configDistPref = combine configDistPref,+ configVerbose = fromFlagOrDefault (configVerbose a) (configVerbosity b),+ configVerbosity = combine configVerbosity,+ configUserInstall = combine configUserInstall,+ configPackageDB = combine configPackageDB,+ configGHCiLib = combine configGHCiLib,+ configSplitObjs = combine configSplitObjs,+ configStripExes = combine configSplitObjs,+ configExtraLibDirs = combine configExtraLibDirs,+ configConstraints = combine configConstraints,+ configExtraIncludeDirs = combine configExtraIncludeDirs,+ configConfigurationsFlags = combine configConfigurationsFlags+ }+ where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Copy flags+-- ------------------------------------------------------------++-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)+data CopyFlags = CopyFlags {+ copyDest :: CopyDest,+ copyDest' :: Flag CopyDest,+ copyDistPref :: Flag FilePath,+ copyVerbose :: Verbosity,+ copyVerbosity :: Flag Verbosity+ }+ deriving Show++defaultCopyFlags :: CopyFlags+defaultCopyFlags = CopyFlags {+ copyDest = NoCopyDest,+ copyDest' = Flag NoCopyDest,+ copyDistPref = Flag defaultDistPref,+ copyVerbose = normal,+ copyVerbosity = Flag normal+ }++copyCommand :: CommandUI CopyFlags+copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options+ where+ name = "copy"+ shortDesc = "Copy the files into the install locations."+ longDesc = Just $ \_ ->+ "Does not call register, and allows a prefix at install time\n"+ ++ "Without the --destdir flag, configure determines location.\n"+ options _ =+ [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v })+ ,optionDistPref copyDistPref (\d flags -> flags { copyDistPref = d })++ ,option "" ["destdir"]+ "directory to copy files to, prepended to installation directories"+ 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 })+ (reqArg' "DIR" (Flag . CopyPrefix)+ (\f -> case f of Flag (CopyPrefix p) -> [p]; _ -> []))++ ]++emptyCopyFlags :: CopyFlags+emptyCopyFlags = mempty++instance Monoid CopyFlags where+ mempty = CopyFlags {+ copyDest = NoCopyDest,+ copyDest' = mempty,+ copyDistPref = mempty,+ copyVerbose = normal,+ copyVerbosity = mempty+ }+ mappend a b = CopyFlags {+ copyDest = fromFlagOrDefault (copyDest a) (copyDest' b),+ copyDest' = combine copyDest',+ copyDistPref = combine copyDistPref,+ copyVerbose = fromFlagOrDefault (copyVerbose a) (copyVerbosity b),+ copyVerbosity = combine copyVerbosity+ }+ where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Install flags+-- ------------------------------------------------------------++-- | Flags to @install@: (package db, verbosity)+data InstallFlags = InstallFlags {+ installPackageDB :: Flag PackageDB,+ installDistPref :: Flag FilePath,+ installVerbose :: Verbosity,+ installVerbosity :: Flag Verbosity+ }+ deriving Show++defaultInstallFlags :: InstallFlags+defaultInstallFlags = InstallFlags {+ installPackageDB = NoFlag,+ installDistPref = Flag defaultDistPref,+ installVerbose = normal,+ installVerbosity = Flag normal+ }++installCommand :: CommandUI InstallFlags+installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options+ where+ name = "install"+ shortDesc = "Copy the files into the install locations. Run register."+ longDesc = Just $ \_ ->+ "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 _ =+ [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v })+ ,optionDistPref installDistPref (\d flags -> flags { installDistPref = d })++ ,option "" ["packageDB"] ""+ installPackageDB (\v flags -> flags { installPackageDB = v })+ (choiceOpt [ (Flag UserPackageDB, ([],["user"]),+ "upon configuration register this package in the user's local package database")+ , (Flag GlobalPackageDB, ([],["global"]),+ "(default) upon configuration register this package in the system-wide package database")])+ ]++emptyInstallFlags :: InstallFlags+emptyInstallFlags = mempty++instance Monoid InstallFlags where+ mempty = InstallFlags{+ installPackageDB = mempty,+ installDistPref = mempty,+ installVerbose = normal,+ installVerbosity = mempty+ }+ mappend a b = InstallFlags{+ installPackageDB = combine installPackageDB,+ installDistPref = combine installDistPref,+ installVerbose = fromFlagOrDefault (installVerbose a) (installVerbosity b),+ installVerbosity = combine installVerbosity+ }+ where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * SDist flags+-- ------------------------------------------------------------++-- | Flags to @sdist@: (snapshot, verbosity)+data SDistFlags = SDistFlags {+ sDistSnapshot :: Flag Bool,+ sDistDistPref :: Flag FilePath,+ sDistVerbose :: Verbosity,+ sDistVerbosity :: Flag Verbosity+ }+ deriving Show++defaultSDistFlags :: SDistFlags+defaultSDistFlags = SDistFlags {+ sDistSnapshot = Flag False,+ sDistDistPref = Flag defaultDistPref,+ sDistVerbose = normal,+ sDistVerbosity = Flag normal+ }++sdistCommand :: CommandUI SDistFlags+sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options+ where+ name = "sdist"+ shortDesc = "Generate a source distribution file (.tar.gz)."+ longDesc = Nothing+ options _ =+ [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })+ ,optionDistPref sDistDistPref (\d flags -> flags { sDistDistPref = d })++ ,option "" ["snapshot"]+ "Produce a snapshot source distribution"+ sDistSnapshot (\v flags -> flags { sDistSnapshot = v })+ trueArg+ ]++emptySDistFlags :: SDistFlags+emptySDistFlags = mempty++instance Monoid SDistFlags where+ 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++-- ------------------------------------------------------------+-- * Register flags+-- ------------------------------------------------------------++-- | Flags to @register@ and @unregister@: (user package, gen-script,+-- in-place, verbosity)+data RegisterFlags = RegisterFlags {+ regPackageDB :: Flag PackageDB,+ regGenScript :: Flag Bool,+ regGenPkgConf :: Flag (Maybe FilePath),+ regInPlace :: Flag Bool,+ regDistPref :: Flag FilePath,+ regVerbose :: Verbosity,+ regVerbosity :: Flag Verbosity+ }+ deriving Show++defaultRegisterFlags :: RegisterFlags+defaultRegisterFlags = RegisterFlags {+ regPackageDB = NoFlag,+ regGenScript = Flag False,+ regGenPkgConf = NoFlag,+ regInPlace = Flag False,+ regDistPref = Flag defaultDistPref,+ regVerbose = normal,+ regVerbosity = Flag normal+ }++registerCommand :: CommandUI RegisterFlags+registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+ where+ name = "register"+ shortDesc = "Register this package with the compiler."+ longDesc = Nothing+ options _ =+ [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })+ ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d })++ ,option "" ["packageDB"] ""+ regPackageDB (\v flags -> flags { regPackageDB = v })+ (choiceOpt [ (Flag UserPackageDB, ([],["user"]),+ "upon registration, register this package in the user's local package database")+ , (Flag GlobalPackageDB, ([],["global"]),+ "(default)upon registration, register this package in the system-wide package database")])++ ,option "" ["inplace"]+ "register the package in the build location, so it can be used without being installed"+ regInPlace (\v flags -> flags { regInPlace = v })+ trueArg++ ,option "" ["gen-script"]+ "instead of registering, generate a script to register later"+ regGenScript (\v flags -> flags { regGenScript = v })+ trueArg++ ,option "" ["gen-pkg-config"]+ "instead of registering, generate a package registration file"+ regGenPkgConf (\v flags -> flags { regGenPkgConf = v })+ (optArg' "PKG" Flag flagToList)+ ]++unregisterCommand :: CommandUI RegisterFlags+unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+ where+ name = "unregister"+ shortDesc = "Unregister this package with the compiler."+ longDesc = Nothing+ options _ =+ [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })+ ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d })++ ,option "" ["user"] ""+ regPackageDB (\v flags -> flags { regPackageDB = v })+ (choiceOpt [ (Flag UserPackageDB, ([],["user"]),+ "unregister this package in the user's local package database")+ , (Flag GlobalPackageDB, ([],["global"]),+ "(default) unregister this package in the system-wide package database")])++ ,option "" ["gen-script"]+ "Instead of performing the unregister command, generate a script to unregister later"+ regGenScript (\v flags -> flags { regGenScript = v })+ trueArg+ ]++emptyRegisterFlags :: RegisterFlags+emptyRegisterFlags = mempty++instance Monoid RegisterFlags where+ mempty = RegisterFlags {+ regPackageDB = mempty,+ regGenScript = mempty,+ regGenPkgConf = mempty,+ regInPlace = mempty,+ regDistPref = mempty,+ regVerbose = normal,+ regVerbosity = mempty+ }+ mappend a b = RegisterFlags {+ regPackageDB = combine regPackageDB,+ regGenScript = combine regGenScript,+ 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++-- ------------------------------------------------------------+-- * HsColour flags+-- ------------------------------------------------------------++data HscolourFlags = HscolourFlags {+ hscolourCSS :: Flag FilePath,+ hscolourExecutables :: Flag Bool,+ hscolourDistPref :: Flag FilePath,+ hscolourVerbose :: Verbosity,+ hscolourVerbosity :: Flag Verbosity+ }+ deriving Show++emptyHscolourFlags :: HscolourFlags+emptyHscolourFlags = mempty++defaultHscolourFlags :: HscolourFlags+defaultHscolourFlags = HscolourFlags {+ hscolourCSS = NoFlag,+ hscolourExecutables = Flag False,+ hscolourDistPref = Flag defaultDistPref,+ hscolourVerbose = normal,+ hscolourVerbosity = Flag normal+ }++instance Monoid HscolourFlags where+ mempty = HscolourFlags {+ 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++hscolourCommand :: CommandUI HscolourFlags+hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options+ where+ name = "hscolour"+ shortDesc = "Generate HsColour colourised code, in HTML format."+ longDesc = Just (\_ -> "Requires hscolour.")+ options _ =+ [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v })+ ,optionDistPref hscolourDistPref (\d flags -> flags { hscolourDistPref = d })++ ,option "" ["executables"]+ "Run hscolour for Executables targets"+ hscolourExecutables (\v flags -> flags { hscolourExecutables = v })+ trueArg++ ,option "" ["css"]+ "Use a cascading style sheet"+ hscolourCSS (\v flags -> flags { hscolourCSS = v })+ (reqArgFlag "PATH")+ ]++-- ------------------------------------------------------------+-- * Haddock flags+-- ------------------------------------------------------------++data HaddockFlags = HaddockFlags {+ haddockHoogle :: Flag Bool,+ haddockHtmlLocation :: Flag String,+ haddockExecutables :: Flag Bool,+ haddockInternal :: Flag Bool,+ haddockCss :: Flag FilePath,+ haddockHscolour :: Flag Bool,+ haddockHscolourCss :: Flag FilePath,+ haddockDistPref :: Flag FilePath,+ haddockVerbose :: Verbosity,+ haddockVerbosity :: Flag Verbosity+ }+ deriving Show++defaultHaddockFlags :: HaddockFlags+defaultHaddockFlags = HaddockFlags {+ haddockHoogle = Flag False,+ haddockHtmlLocation = NoFlag,+ haddockExecutables = Flag False,+ haddockInternal = Flag False,+ haddockCss = NoFlag,+ haddockHscolour = Flag False,+ haddockHscolourCss = NoFlag,+ haddockDistPref = Flag defaultDistPref,+ haddockVerbose = normal,+ haddockVerbosity = Flag normal+ }++haddockCommand :: CommandUI HaddockFlags+haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options+ where+ name = "haddock"+ shortDesc = "Generate Haddock HTML documentation."+ longDesc = Just (\_ -> "Requires cpphs and haddock.\n")+ options _ =+ [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v })+ ,optionDistPref haddockDistPref (\d flags -> flags { haddockDistPref = d })++ ,option "" ["hoogle"]+ "Generate a hoogle database"+ haddockHoogle (\v flags -> flags { haddockHoogle = v })+ trueArg++ ,option "" ["html-location"]+ "Location of HTML documentation for pre-requisite packages"+ haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })+ (reqArgFlag "URL")++ ,option "" ["executables"]+ "Run haddock for Executables targets"+ haddockExecutables (\v flags -> flags { haddockExecutables = v })+ trueArg++ ,option "" ["internal"]+ "Run haddock for internal modules and include all symbols"+ haddockInternal (\v flags -> flags { haddockInternal = v })+ trueArg++ ,option "" ["css"]+ "Use PATH as the haddock stylesheet"+ haddockCss (\v flags -> flags { haddockCss = v })+ (reqArgFlag "PATH")++ ,option "" ["hyperlink-source"]+ "Hyperlink the documentation to the source code (using HsColour)"+ haddockHscolour (\v flags -> flags { haddockHscolour = v })+ trueArg++ ,option "" ["hscolour-css"]+ "Use PATH as the HsColour stylesheet"+ haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })+ (reqArgFlag "PATH")+ ]++emptyHaddockFlags :: HaddockFlags+emptyHaddockFlags = mempty++instance Monoid HaddockFlags where+ mempty = HaddockFlags {+ haddockHoogle = mempty,+ haddockHtmlLocation = mempty,+ haddockExecutables = mempty,+ haddockInternal = mempty,+ haddockCss = mempty,+ haddockHscolour = mempty,+ haddockHscolourCss = mempty,+ haddockDistPref = mempty,+ haddockVerbose = normal,+ haddockVerbosity = mempty+ }+ mappend a b = HaddockFlags {+ haddockHoogle = combine haddockHoogle,+ haddockHtmlLocation = combine haddockHtmlLocation,+ haddockExecutables = combine haddockExecutables,+ haddockInternal = combine haddockInternal,+ haddockCss = combine haddockCss,+ 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++-- ------------------------------------------------------------+-- * Clean flags+-- ------------------------------------------------------------++data CleanFlags = CleanFlags {+ cleanSaveConf :: Flag Bool,+ cleanDistPref :: Flag FilePath,+ cleanVerbose :: Verbosity,+ cleanVerbosity :: Flag Verbosity+ }+ deriving Show++defaultCleanFlags :: CleanFlags+defaultCleanFlags = CleanFlags {+ cleanSaveConf = Flag False,+ cleanDistPref = Flag defaultDistPref,+ cleanVerbose = normal,+ cleanVerbosity = Flag normal+ }++cleanCommand :: CommandUI CleanFlags+cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options+ where+ name = "clean"+ shortDesc = "Clean up after a build."+ longDesc = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n")+ options _ =+ [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v })+ ,optionDistPref cleanDistPref (\d flags -> flags { cleanDistPref = d })++ ,option "s" ["save-configure"]+ "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure."+ cleanSaveConf (\v flags -> flags { cleanSaveConf = v })+ trueArg+ ]++emptyCleanFlags :: CleanFlags+emptyCleanFlags = mempty++instance Monoid CleanFlags where+ 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++-- ------------------------------------------------------------+-- * Build flags+-- ------------------------------------------------------------++data BuildFlags = BuildFlags {+ buildProgramArgs :: [(String, [String])],+ buildDistPref :: Flag FilePath,+ buildVerbose :: Verbosity,+ buildVerbosity :: Flag Verbosity+ }+ deriving Show++defaultBuildFlags :: BuildFlags+defaultBuildFlags = BuildFlags {+ buildProgramArgs = [],+ buildDistPref = Flag defaultDistPref,+ buildVerbose = normal,+ buildVerbosity = Flag normal+ }++buildCommand :: ProgramConfiguration -> CommandUI BuildFlags+buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options+ where+ name = "build"+ shortDesc = "Make this package ready for installation."+ longDesc = Nothing+ options showOrParseArgs =+ optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })+ : optionDistPref buildDistPref (\d flags -> flags { buildDistPref = d })++ : programConfigurationOptions progConf showOrParseArgs+ buildProgramArgs (\v flags -> flags { buildProgramArgs = v})++emptyBuildFlags :: BuildFlags+emptyBuildFlags = mempty++instance Monoid BuildFlags where+ mempty = BuildFlags {+ buildProgramArgs = mempty,+ buildVerbose = normal,+ buildVerbosity = Flag normal,+ buildDistPref = mempty+ }+ mappend a b = BuildFlags {+ buildProgramArgs = combine buildProgramArgs,+ buildVerbose = fromFlagOrDefault (buildVerbose a) (buildVerbosity b),+ buildVerbosity = combine buildVerbosity,+ buildDistPref = combine buildDistPref+ }+ where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Makefile flags+-- ------------------------------------------------------------++data MakefileFlags = MakefileFlags {+ makefileFile :: Flag FilePath,+ makefileDistPref :: Flag FilePath,+ makefileVerbose :: Verbosity,+ makefileVerbosity :: Flag Verbosity+ }+ deriving Show++defaultMakefileFlags :: MakefileFlags+defaultMakefileFlags = MakefileFlags {+ makefileFile = NoFlag,+ makefileDistPref = Flag defaultDistPref,+ makefileVerbose = normal,+ makefileVerbosity = Flag normal+ }++makefileCommand :: CommandUI MakefileFlags+makefileCommand = makeCommand name shortDesc longDesc defaultMakefileFlags options+ where+ name = "makefile"+ shortDesc = "Generate a makefile (only for GHC libraries)."+ longDesc = Nothing+ options _ =+ [optionVerbosity makefileVerbosity (\v flags -> flags { makefileVerbosity = v })+ ,optionDistPref makefileDistPref (\d flags -> flags { makefileDistPref = d })++ ,option "f" ["file"]+ "Filename to use (default: Makefile)."+ makefileFile (\f flags -> flags { makefileFile = f })+ (reqArgFlag "PATH")+ ]++emptyMakefileFlags :: MakefileFlags+emptyMakefileFlags = mempty++instance Monoid MakefileFlags where+ 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++-- ------------------------------------------------------------+-- * Test flags+-- ------------------------------------------------------------++data TestFlags = TestFlags {+ testDistPref :: Flag FilePath,+ testVerbosity :: Flag Verbosity+ }+ deriving Show++defaultTestFlags :: TestFlags+defaultTestFlags = TestFlags {+ testDistPref = Flag defaultDistPref,+ testVerbosity = Flag normal+ }++testCommand :: CommandUI TestFlags+testCommand = makeCommand name shortDesc longDesc defaultTestFlags options+ where+ name = "test"+ shortDesc = "Run the test suite, if any (configure with UserHooks)."+ longDesc = Nothing+ options _ =+ [optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })+ ,optionDistPref testDistPref (\d flags -> flags { testDistPref = d })+ ]++emptyTestFlags :: TestFlags+emptyTestFlags = mempty++instance Monoid TestFlags where+ mempty = TestFlags {+ testDistPref = mempty,+ testVerbosity = mempty+ }+ mappend a b = TestFlags {+ testDistPref = combine testDistPref,+ testVerbosity = combine testVerbosity+ }+ where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Shared options utils+-- ------------------------------------------------------------++programFlagsDescription :: ProgramConfiguration -> String+programFlagsDescription progConf =+ "The flags --with-PROG and --PROG-option(s) can be used with"+ ++ " the following programs:"+ ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort)+ [ programName prog | (prog, _) <- knownPrograms progConf ]+ ++ "\n"++programConfigurationPaths+ :: ProgramConfiguration+ -> ShowOrParseArgs+ -> (flags -> [(String, FilePath)])+ -> ([(String, FilePath)] -> (flags -> flags))+ -> [OptionField flags]+programConfigurationPaths progConf showOrParseArgs get set =+ case showOrParseArgs of+ -- we don't want a verbose help text list so we just show a generic one:+ ShowArgs -> [withProgramPath "PROG"]+ ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf)+ where+ withProgramPath prog =+ option "" ["with-" ++ prog]+ ("give the path to " ++ prog)+ get set+ (reqArg' "PATH" (\path -> [(prog, path)])+ (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))++programConfigurationOptions+ :: ProgramConfiguration+ -> ShowOrParseArgs+ -> (flags -> [(String, [String])])+ -> ([(String, [String])] -> (flags -> flags))+ -> [OptionField flags]+programConfigurationOptions progConf showOrParseArgs get set =+ case showOrParseArgs of+ -- we don't want a verbose help text list so we just show a generic one:+ ShowArgs -> [programOptions "PROG", programOption "PROG"]+ ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf)+ ++ map (programOption . programName . fst) (knownPrograms progConf)+ where+ programOptions prog =+ option "" [prog ++ "-options"]+ ("give extra options to " ++ prog)+ get set+ (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))++ programOption prog =+ option "" [prog ++ "-option"]+ ("give an extra option to " ++ prog +++ " (no need to quote options containing spaces)")+ get set+ (reqArg' "OPT" (\arg -> [(prog, [arg])])+ (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ]))+ ++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt = Command.boolOpt flagToMaybe Flag++boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt' = Command.boolOpt' flagToMaybe Flag++trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->+ (Flag Bool -> (b -> b)) -> OptDescr b+trueArg = noArg (Flag True)+falseArg = noArg (Flag False)++reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->+ (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList++optionDistPref :: (flags -> Flag FilePath)+ -> (Flag FilePath -> flags -> flags)+ -> OptionField flags+optionDistPref get set =+ option "" ["distpref"]+ ( "Control which directory Cabal puts its generated files in "+ ++ "(default " ++ defaultDistPref ++ ")")+ get set+ (reqArgFlag "DIR")++optionVerbosity :: (flags -> Flag Verbosity)+ -> (Flag Verbosity -> flags -> flags)+ -> OptionField flags+optionVerbosity get set =+ option "v" ["verbose"]+ "Control verbosity (n is 0--3, default verbosity level is 1)"+ get set+ (optArg "n" (fmap Flag flagToVerbosity)+ (Flag verbose) -- default Value if no n is given+ (fmap (Just . showForCabal) . flagToList))++-- ------------------------------------------------------------+-- * Other Utils+-- ------------------------------------------------------------++-- | Arguments to pass to a @configure@ script, e.g. generated by+-- @autoconf@.+configureArgs :: Bool -> ConfigFlags -> [String]+configureArgs bcHack flags+ = hc_flag+ ++ optFlag "with-hc-pkg" configHcPkg+ ++ optFlag' "prefix" prefix+ ++ optFlag' "bindir" bindir+ ++ optFlag' "libdir" libdir+ ++ optFlag' "libexecdir" libexecdir+ ++ optFlag' "datadir" datadir+ ++ configConfigureArgs flags+ where+ hc_flag = case (configHcFlavor flags, configHcPath flags) of+ (_, Flag hc_path) -> [hc_flag_name ++ hc_path]+ (Flag hc, NoFlag) -> [hc_flag_name ++ display hc]+ (NoFlag,NoFlag) -> []+ hc_flag_name+ --TODO kill off thic bc hack when defaultUserHooks is removed.+ | bcHack = "--with-hc="+ | otherwise = "--with-compiler="+ optFlag name config_field = case config_field flags of+ Flag p -> ["--" ++ name ++ "=" ++ p]+ NoFlag -> []+ optFlag' name config_field = optFlag name (fmap fromPathTemplate+ . config_field+ . configInstallDirs)++-- | Helper function to split a string into a list of arguments.+-- It's supposed to handle quoted things sensibly, eg:+--+-- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz"+-- > = ["--foo=C:\Program Files\Bar", "--baz"]+--+splitArgs :: String -> [String]+splitArgs = space []+ where+ space :: String -> String -> [String]+ space w [] = word w []+ space w ( c :s)+ | isSpace c = word w (space [] s)+ space w ('"':s) = string w s+ space w s = nonstring w s++ string :: String -> String -> [String]+ string w [] = word w []+ string w ('"':s) = space w s+ string w ( c :s) = string (c:w) s++ nonstring :: String -> String -> [String]+ nonstring w [] = word w []+ nonstring w ('"':s) = string w s+ nonstring w ( c :s) = space (c:w) s++ word [] s = s+ word w s = reverse w : s++-- The test cases kinda have to be rewritten from the ground up... :/+--hunitTests :: [Test]+--hunitTests =+-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)]+-- (flags, commands', unkFlags, ers)+-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]+-- in [TestLabel "very basic option parsing" $ TestList [+-- "getOpt flags" ~: "failed" ~:+-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag,+-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag]+-- ~=? flags,+-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands',+-- "getOpt unknown opts" ~: "failed" ~:+-- ["--unknown1", "--unknown2"] ~=? unkFlags,+-- "getOpt errors" ~: "failed" ~: [] ~=? ers],+--+-- TestLabel "test location of various compilers" $ TestList+-- ["configure parsing for prefix and compiler flag" ~: "failed" ~:+-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), []))+-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"])+-- | (name, comp) <- m],+--+-- TestLabel "find the package tool" $ TestList+-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~:+-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), []))+-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name,+-- "--with-compiler=/foo/comp", "configure"])+-- | (name, comp) <- m],+--+-- TestLabel "simpler commands" $ TestList+-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag])+-- | (flag, flagCmd) <- [("build", BuildCmd),+-- ("install", InstallCmd Nothing False),+-- ("sdist", SDistCmd),+-- ("register", RegisterCmd False)]+-- ]+-- ]++{- Testing ideas:+ * IO to look for hugs and hugs-pkg (which hugs, etc)+ * quickCheck to test permutations of arguments+ * what other options can we over-ride with a command-line flag?+-}
Distribution/Simple/SetupWrapper.hs view
@@ -21,24 +21,24 @@ import Distribution.Simple.Configure ( configCompiler, getInstalledPackages, configDependency )-import Distribution.Simple.Setup ( reqPathArg )-import Distribution.PackageDescription - ( readPackageDescription,- GenericPackageDescription(packageDescription),- PackageDescription(..),- BuildType(..), cabalVersion )-import Distribution.Simple.LocalBuildInfo ( distPref )+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.Compat.Exception ( finally ) 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@@ -57,10 +57,11 @@ -- dependencies here and building/installing the sub packages -- in the right order. setupWrapper :: - [String] -- ^ Command-line arguments.+ FilePath -- ^ "dist" prefix+ -> [String] -- ^ Command-line arguments. -> Maybe FilePath -- ^ Directory to run in. If 'Nothing', the current directory is used. -> IO ()-setupWrapper args mdir = inDir mdir $ do +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@@ -94,13 +95,14 @@ ++ ghcVerbosityOptions verbosity rawSystemExit verbosity setupProg args - case lookup (buildType (packageDescription ppkg_descr)) buildTypes of+ 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- writeFile setupHs mainText+ writeUTF8File setupHs mainText trySetupScript setupHs $ error "panic! shouldn't happen" Nothing -> trySetupScript "Setup.hs" $@@ -110,17 +112,10 @@ buildTypes :: [(BuildType, ([String] -> IO (), String))] buildTypes = [ (Simple, (defaultMainArgs, "import Distribution.Simple; main=defaultMain")),- (Configure, (defaultMainWithHooksArgs defaultUserHooks,- "import Distribution.Simple; main=defaultMainWithHooks defaultUserHooks")),+ (Configure, (defaultMainWithHooksArgs autoconfUserHooks,+ "import Distribution.Simple; main=defaultMainWithHooks autoconfUserHooks")), (Make, (Make.defaultMainArgs, "import Distribution.Make; main=defaultMain"))] -inDir :: Maybe FilePath -> IO () -> IO ()-inDir Nothing m = m-inDir (Just d) m = do- old <- getCurrentDirectory- setCurrentDirectory d- m `finally` setCurrentDirectory old- data Flags = Flags { withCompiler :: Maybe FilePath,@@ -146,19 +141,20 @@ opts :: [OptDescr (Flags -> Flags)] opts = [- Option "w" ["with-setup-compiler"] (reqPathArg (setWithCompiler.Just))+ 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"] (reqPathArg (setWithHcPkg.Just))+ Option "" ["with-setup-hc-pkg"] (ReqArg (setWithHcPkg.Just) "PATH") "give the path to the package tool to use on setup",- Option "v" ["verbose"] (OptArg (setVerbosity . flagToVerbosity) "n")+ 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- ipkgs <- getInstalledPackages verbosity comp UserPackageDB conf- >>= return . fromMaybe []+ packageIndex <- fromMaybe mempty+ `fmap` getInstalledPackages verbosity comp UserPackageDB conf -- user packages are *allowed* here, no portability problem- cabal_pkgid <- configDependency verbosity ipkgs (Dependency "Cabal" range)- return ["-package", showPackageId cabal_pkgid]+ cabal_pkgid <- configDependency verbosity packageIndex (Dependency "Cabal" range)+ return ["-package", display cabal_pkgid]
Distribution/Simple/SrcDist.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.SrcDist@@ -47,106 +46,115 @@ -- we can't easily look inside a tarball once its created. module Distribution.Simple.SrcDist (- sdist- ,createArchive- ,prepareTree- ,tarBallName- ,copyFileTo-#ifdef DEBUG - ,hunitTests-#endif+ -- * The top level action+ sdist,++ -- ** Parts of 'sdist'+ printPackageProblems,+ prepareTree,+ createArchive,++ -- ** Snaphots+ prepareSnapshotTree,+ snapshotVersion,+ dateToSnapshotNumber, ) where import Distribution.PackageDescription- (PackageDescription(..), BuildInfo(..), Executable(..), Library(..),- withLib, withExe, setupMessage)-import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion))-import Distribution.Version (Version(versionBranch), VersionRange(AnyVersion))-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,- smartCopySources, die, warn, notice,- findPackageDesc, findFile, findFileWithExtension,- copyFileVerbose)-import Distribution.Simple.Setup (SDistFlags(..))+ ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) )+import Distribution.PackageDescription.Check+import Distribution.Package+ ( PackageIdentifier(pkgVersion), Package(..) )+import Distribution.Version+ ( Version(versionBranch), VersionRange(AnyVersion) )+import Distribution.Simple.Utils+ ( createDirectoryIfMissingVerbose, readUTF8File, writeUTF8File+ , copyFiles, copyFileVerbose, findFile, findFileWithExtension+ , withTempDirectory, dotToSep, defaultPackageDesc+ , die, warn, notice, setupMessage )+import Distribution.Simple.Setup (SDistFlags(..), fromFlag) import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, rawSystemProgram, tarProgram )+import Distribution.Text+ ( display ) -#ifndef __NHC__-import Control.Exception (finally)-#endif-import Control.Monad(when)-import Data.Char (isSpace, toLower)-import Data.List (isPrefixOf)+import Control.Monad(when, unless)+import Data.Char (toLower)+import Data.List (partition, isPrefixOf)+import Data.Maybe (isNothing, catMaybes) import System.Time (getClockTime, toCalendarTime, CalendarTime(..))-import Distribution.Compat.Directory (doesFileExist, doesDirectoryExist,- getCurrentDirectory, removeDirectoryRecursive)-import Distribution.Verbosity-import System.FilePath ((</>), takeDirectory, isAbsolute, dropExtension)--#ifdef DEBUG-import Test.HUnit (Test)-#endif--#ifdef __NHC__-finally :: IO a -> IO b -> IO a-x `finally` y = do { a <- x; y; return a }-#endif+import System.Directory (doesFileExist, doesDirectoryExist)+import Distribution.Verbosity (Verbosity)+import System.FilePath+ ( (</>), (<.>), takeDirectory, dropExtension, isAbsolute ) -- |Create a source distribution. sdist :: PackageDescription -- ^information from the tarball -> Maybe LocalBuildInfo -- ^Information from configure -> SDistFlags -- ^verbosity & snapshot- -> FilePath -- ^build prefix (temp dir)- -> FilePath -- ^TargetPrefix+ -> (FilePath -> FilePath) -- ^build prefix (temp dir) -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO ()-sdist pkg_descr_orig mb_lbi (SDistFlags snapshot verbosity) tmpDir targetPref pps = do- time <- getClockTime- ct <- toCalendarTime time- let date = ctYear ct*10000 + (fromEnum (ctMonth ct) + 1)*100 + ctDay ct- let pkg_descr- | snapshot = updatePackage (updatePkgVersion- (updateVersionBranch (++ [date]))) pkg_descr_orig- | otherwise = pkg_descr_orig- prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date- createArchive pkg_descr verbosity mb_lbi tmpDir targetPref- return ()+sdist pkg mb_lbi flags mkTmpDir pps = do+ let distPref = fromFlag $ sDistDistPref flags+ targetPref = distPref+ tmpDir = mkTmpDir distPref++ -- do some QA+ printPackageProblems verbosity pkg++ exists <- doesDirectoryExist tmpDir+ when exists $+ die $ "Source distribution already in place. please move or remove: "+ ++ tmpDir++ when (isNothing mb_lbi) $+ warn verbosity "Cannot run preprocessors. Run 'configure' command first."++ withTempDirectory verbosity tmpDir $ do++ 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+ targzFile <- createArchive verbosity pkg mb_lbi tmpDir targetPref+ notice verbosity $ "Source tarball created: " ++ targzFile+ where- updatePackage f pd = pd { package = f (package pd) }- updatePkgVersion f pkg = pkg { pkgVersion = f (pkgVersion pkg) }- updateVersionBranch f v = v { versionBranch = f (versionBranch v) }+ verbosity = fromFlag (sDistVerbosity flags)+ snapshot = fromFlag (sDistSnapshot flags) -- |Prepare a directory tree of source files.-prepareTree :: PackageDescription -- ^info from the cabal file- -> Verbosity -- ^verbosity+prepareTree :: Verbosity -- ^verbosity+ -> PackageDescription -- ^info from the cabal file -> Maybe LocalBuildInfo- -> Bool -- ^snapshot+ -> FilePath -- ^dist dir -> FilePath -- ^source tree to populate -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes)- -> Int -- ^date- -> IO FilePath+ -> IO FilePath -- ^the name of the dir created and populated -prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date = do- setupMessage verbosity "Building source dist for" pkg_descr- ex <- doesDirectoryExist tmpDir- when ex (die $ "Source distribution already in place. please move: " ++ tmpDir)- let targetDir = tmpDir </> (nameVersion pkg_descr)+prepareTree verbosity pkg_descr mb_lbi distPref tmpDir pps = do+ let targetDir = tmpDir </> tarBallName pkg_descr createDirectoryIfMissingVerbose verbosity True targetDir -- maybe move the library files into place- withLib pkg_descr () $ \ l ->- prepareDir verbosity targetDir pps (exposedModules l) (libBuildInfo l)+ withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->+ prepareDir verbosity pkg_descr distPref targetDir pps modules libBi -- move the executables into place- withExe pkg_descr $ \ (Executable _ mainPath exeBi) -> do- prepareDir verbosity targetDir pps [] exeBi+ withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do+ prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi srcMainFile <- do ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) case ppFile of Nothing -> findFile (hsSourceDirs exeBi) mainPath Just pp -> return pp copyFileTo verbosity targetDir srcMainFile- flip mapM_ (dataFiles pkg_descr) $ \ file -> do- let dir = takeDirectory file+ flip mapM_ (dataFiles pkg_descr) $ \ filename -> do+ let file = dataDir pkg_descr </> filename+ dir = takeDirectory file createDirectoryIfMissingVerbose verbosity True (targetDir </> dir) copyFileVerbose verbosity file (targetDir </> file) @@ -156,68 +164,111 @@ copyFileTo verbosity targetDir fpath -- copy the install-include files- withLib pkg_descr () $ \ l -> do+ withLib $ \ l -> do let lbi = libBuildInfo l relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) incs <- mapM (findInc relincdirs) (installIncludes lbi) flip mapM_ incs $ \(_,fpath) -> copyFileTo verbosity targetDir fpath - -- we have some preprocessors specified, try to generate those files- when (not (null pps)) $- case mb_lbi of- Just lbi -> preprocessSources pkg_descr (lbi { buildDir = targetDir }) - True verbosity pps- Nothing -> warn verbosity- "Cannot run preprocessors. Run 'configure' command first."+ -- if the package was configured then we can run platform independent+ -- pre-processors and include those generated files+ case mb_lbi of+ Just lbi | not (null pps)+ -> preprocessSources pkg_descr (lbi { buildDir = targetDir </> buildDir lbi })+ True verbosity pps+ _ -> return () -- setup isn't listed in the description file. hsExists <- doesFileExist "Setup.hs" lhsExists <- doesFileExist "Setup.lhs" if hsExists then copyFileTo verbosity targetDir "Setup.hs" else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"- else writeFile (targetDir </> "Setup.hs") $ unlines [+ else writeUTF8File (targetDir </> "Setup.hs") $ unlines [ "import Distribution.Simple", "main = defaultMain"] -- the description file itself- descFile <- getCurrentDirectory >>= findPackageDesc verbosity- let targetDescFile = targetDir </> descFile- -- We could just writePackageDescription targetDescFile pkg_descr,- -- but that would lose comments and formatting.- if snapshot then do- contents <- readFile descFile- writeFile targetDescFile $- unlines $ map (appendVersion date) $ lines $ contents- else copyFileVerbose verbosity descFile targetDescFile+ descFile <- defaultPackageDesc verbosity+ copyFileVerbose verbosity descFile (targetDir </> descFile) return targetDir where-- appendVersion :: Int -> String -> String- appendVersion n line- | "version:" `isPrefixOf` map toLower line =- trimTrailingSpace line ++ "." ++ show n- | otherwise = line-- trimTrailingSpace :: String -> String- trimTrailingSpace = reverse . dropWhile isSpace . reverse- findInc [] f = die ("can't find include file " ++ f) findInc (d:ds) f = do let path = (d </> f) b <- doesFileExist path if b then return (f,path) else findInc ds f + -- We have to deal with all libs and executables, so we have local+ -- versions of these functions that ignore the 'buildable' attribute:+ 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.+--+prepareSnapshotTree :: Verbosity -- ^verbosity+ -> PackageDescription -- ^info from the cabal file+ -> Maybe LocalBuildInfo+ -> 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+ 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)+ . unlines . map (replaceVersion version) . lines+ =<< readUTF8File descFile++ replaceVersion :: Version -> String -> String+ replaceVersion version line+ | "version:" `isPrefixOf` map toLower line+ = "version: " ++ display version+ | otherwise = line++-- | Modifies a 'Version' by appending a snapshot number corresponding+-- to the given date.+--+snapshotVersion :: CalendarTime -> Version -> Version+snapshotVersion date version = version {+ versionBranch = versionBranch version+ ++ [dateToSnapshotNumber date]+ }++-- | Given a date produce a corresponding integer representation.+-- For example given a date @18/03/2008@ produce the number @20080318@.+--+dateToSnapshotNumber :: CalendarTime -> Int+dateToSnapshotNumber date = year * 10000+ + month * 100+ + day+ where+ year = ctYear date+ month = fromEnum (ctMonth date) + 1+ day = ctDay date+ -- |Create an archive from a tree of source files, and clean up the tree.-createArchive :: PackageDescription -- ^info from cabal file- -> Verbosity -- ^verbosity+createArchive :: Verbosity -- ^verbosity+ -> PackageDescription -- ^info from cabal file -> Maybe LocalBuildInfo -- ^info from configure -> FilePath -- ^source tree to archive -> FilePath -- ^name of archive to create -> IO FilePath -createArchive pkg_descr verbosity mb_lbi tmpDir targetPref = do- let tarBallFilePath = targetPref </> tarBallName pkg_descr+createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do+ let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram AnyVersion (maybe defaultProgramConfiguration withPrograms mb_lbi)@@ -226,44 +277,68 @@ -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly, -- which is problematic in a Windows setting.] rawSystemProgram verbosity tarProg- ["-C", tmpDir, "-czf", tarBallFilePath, nameVersion pkg_descr]- -- XXX this should be done back where tmpDir is made, not here- `finally` removeDirectoryRecursive tmpDir- notice verbosity $ "Source tarball created: " ++ tarBallFilePath+ ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr] return tarBallFilePath -- |Move the sources into place based on buildInfo prepareDir :: Verbosity -- ^verbosity+ -> PackageDescription -- ^info from the cabal file+ -> FilePath -- ^dist dir -> FilePath -- ^TargetPrefix -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> [String] -- ^Exposed modules -> BuildInfo -> IO ()-prepareDir verbosity inPref pps mods BuildInfo{hsSourceDirs=srcDirs, otherModules=mods', cSources=cfiles}- = do let suff = ppSuffixes pps ++ ["hs", "lhs"]- smartCopySources verbosity srcDirs inPref (mods++mods') suff True True- mapM_ (copyFileTo verbosity inPref) cfiles+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_+ in findFileWithExtension suffixes searchDirs file+ >>= maybe (notFound module_) return+ | module_ <- modules ++ otherModules bi ]+ bootFiles <- sequence+ [ let file = dotToSep module_+ in findFileWithExtension ["hs-boot"] (hsSourceDirs bi) file+ | module_ <- modules ++ otherModules bi ] + let allSources = sources ++ catMaybes bootFiles ++ cSources bi+ copyFiles verbosity inPref (zip (repeat []) allSources)++ where suffixes = ppSuffixes pps ++ ["hs", "lhs"]+ notFound m = die $ "Error: Could not find module: " ++ m+ ++ " with any suffix: " ++ show suffixes+ copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () copyFileTo verbosity dir file = do let targetFile = dir </> file createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) copyFileVerbose verbosity file targetFile ----------------------------------------------------------------- |The file name of the tarball-tarBallName :: PackageDescription -> FilePath-tarBallName p = (nameVersion p) ++ ".tar.gz"--nameVersion :: PackageDescription -> String-nameVersion = showPackageId . package+printPackageProblems :: Verbosity -> PackageDescription -> IO ()+printPackageProblems verbosity pkg_descr = do+ ioChecks <- checkPackageFiles pkg_descr "."+ let pureChecks = checkConfiguredPackage pkg_descr+ isDistError (PackageDistSuspicious _) = False+ isDistError _ = True+ (errors, warnings) = partition isDistError (pureChecks ++ ioChecks)+ unless (null errors) $+ notice verbosity $ "Distribution quality errors:\n"+ ++ unlines (map explanation errors)+ unless (null warnings) $+ notice verbosity $ "Distribution quality warnings:\n"+ ++ unlines (map explanation warnings)+ unless (null errors) $+ notice verbosity+ "Note: the public hackage server would reject this package." --- --------------------------------------------------------------- * Testing--- ------------------------------------------------------------+------------------------------------------------------------ -#ifdef DEBUG-hunitTests :: [Test]-hunitTests = []-#endif+-- | The name of the tarball without extension+--+tarBallName :: PackageDescription -> String+tarBallName = display . packageId
+ Distribution/Simple/UserHooks.hs view
@@ -0,0 +1,213 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.UserHooks+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- 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 module isn't called \"Simple\" because it's simple. Far from+-- it. It's called \"Simple\" because it does complicated things to+-- simple software.++{- 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.Simple.UserHooks (+ UserHooks(..), Args,+ emptyUserHooks,+ ) where++import Distribution.PackageDescription+ (PackageDescription, GenericPackageDescription,+ HookedBuildInfo, emptyHookedBuildInfo)+import Distribution.Simple.Program (Program)+import Distribution.Simple.Command (noExtraFlags)+import Distribution.Simple.PreProcess (PPSuffixHandler)+import Distribution.Simple.Setup+ (ConfigFlags, BuildFlags, MakefileFlags, CleanFlags, CopyFlags,+ InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,+ HaddockFlags)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)++type Args = [String]++-- | Hooks allow authors to add specific functionality before and after a+-- command is run, and also to specify additional preprocessors.+--+-- * WARNING: The hooks interface is under rather constant flux as we try to+-- understand users needs. Setup files that depend on this interface may+-- break in future releases.+data UserHooks = UserHooks {++ -- | Used for @.\/setup test@+ runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (),+ -- | Read the description file+ readDesc :: IO (Maybe PackageDescription),+ -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.+ hookedPreProcessors :: [ PPSuffixHandler ],+ -- | These programs are detected at configure time. Arguments for them are+ -- added to the configure command.+ hookedPrograms :: [Program],++ -- |Hook to run before configure command+ preConf :: Args -> ConfigFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during configure.+ confHook :: ( Either GenericPackageDescription PackageDescription+ , HookedBuildInfo)+ -> ConfigFlags -> IO LocalBuildInfo,+ -- |Hook to run after configure command+ postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before build command. Second arg indicates verbosity level.+ preBuild :: Args -> BuildFlags -> IO HookedBuildInfo,++ -- |Over-ride this hook to gbet different behavior during build.+ buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (),+ -- |Hook to run after build command. Second arg indicates verbosity level.+ postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before makefile command. Second arg indicates verbosity level.+ preMakefile :: Args -> MakefileFlags -> IO HookedBuildInfo,++ -- |Over-ride this hook to get different behavior during makefile.+ makefileHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> MakefileFlags -> IO (),+ -- |Hook to run after makefile command. Second arg indicates verbosity level.+ postMakefile :: Args -> MakefileFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before clean command. Second arg indicates verbosity level.+ preClean :: Args -> CleanFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during clean.+ cleanHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> CleanFlags -> IO (),+ -- |Hook to run after clean command. Second arg indicates verbosity level.+ postClean :: Args -> CleanFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (),++ -- |Hook to run before copy command+ preCopy :: Args -> CopyFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during copy.+ copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (),+ -- |Hook to run after copy command+ postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before install command+ preInst :: Args -> InstallFlags -> IO HookedBuildInfo,++ -- |Over-ride this hook to get different behavior during install.+ instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (),+ -- |Hook to run after install command. postInst should be run+ -- on the target, not on the build machine.+ postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before sdist command. Second arg indicates verbosity level.+ preSDist :: Args -> SDistFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during sdist.+ sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (),+ -- |Hook to run after sdist command. Second arg indicates verbosity level.+ postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (),++ -- |Hook to run before register command+ preReg :: Args -> RegisterFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during registration.+ regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),+ -- |Hook to run after register command+ postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before unregister command+ preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during registration.+ unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),+ -- |Hook to run after unregister command+ postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before hscolour command. Second arg indicates verbosity level.+ preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during hscolour.+ hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (),+ -- |Hook to run after hscolour command. Second arg indicates verbosity level.+ postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (),++ -- |Hook to run before haddock command. Second arg indicates verbosity level.+ preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during haddock.+ haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (),+ -- |Hook to run after haddock command. Second arg indicates verbosity level.+ postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO ()+ }++-- |Empty 'UserHooks' which do nothing.+emptyUserHooks :: UserHooks+emptyUserHooks+ = UserHooks {+ runTests = ru,+ readDesc = return Nothing,+ hookedPreProcessors = [],+ hookedPrograms = [],+ preConf = rn,+ confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),+ postConf = ru,+ preBuild = rn,+ buildHook = ru,+ postBuild = ru,+ preMakefile = rn,+ makefileHook = ru,+ postMakefile = ru,+ preClean = rn,+ cleanHook = ru,+ postClean = ru,+ preCopy = rn,+ copyHook = ru,+ postCopy = ru,+ preInst = rn,+ instHook = ru,+ postInst = ru,+ preSDist = rn,+ sDistHook = ru,+ postSDist = ru,+ preReg = rn,+ regHook = ru,+ postReg = ru,+ preUnreg = rn,+ unregHook = ru,+ postUnreg = ru,+ preHscolour = rn,+ hscolourHook = ru,+ postHscolour = ru,+ preHaddock = rn,+ haddockHook = ru,+ postHaddock = ru+ }+ where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo+ ru _ _ _ _ = return ()
Distribution/Simple/Utils.hs view
@@ -1,8 +1,14 @@ {-# OPTIONS -cpp -fffi #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_GHC -cpp -fffi #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- 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@@ -42,115 +48,149 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Utils (+ cabalVersion,+ cabalBootstrapping,++ -- * logging and errors die, dieWithLocation,- warn, notice, info, debug,+ warn, notice, setupMessage, info, debug,+ chattyTry, breaks,- wrapText,++ -- * running programs rawSystemExit, rawSystemStdout, rawSystemStdout', maybeExit, xargs,- matchesDescFile,- rawSystemPathExit,+ inDir,++ -- * copying files smartCopySources, createDirectoryIfMissingVerbose, copyFileVerbose, copyDirectoryRecursiveVerbose,- moduleToFilePath,- moduleToFilePath2,- mkLibName,- mkProfLibName,- mkSharedLibName,+ copyFiles,++ -- * file names currentDir, dotToSep,++ -- * finding files findFile, findFileWithExtension, findFileWithExtension',++ -- * temp files and dirs+ withTempFile,+ withTempDirectory,++ -- * .cabal and .buildinfo files defaultPackageDesc, findPackageDesc, defaultHookedPackageDesc, findHookedPackageDesc,- exeExtension,- objExtension,- dllExtension,-#ifdef DEBUG- hunitTests-#endif- ) where -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604-#if __GLASGOW_HASKELL__ < 603-#include "config.h"-#else-#include "ghcconfig.h"-#endif-#endif+ -- * reading and writing files safely+ withFileContents,+ writeFileAtomic, + -- * Unicode+ fromUTF8,+ toUTF8,+ readUTF8File,+ withUTF8FileContents,+ writeUTF8File,++ -- * generic utils+ equating,+ comparing,+ isInfixOf,+ intercalate,+ lowercase,+ wrapText,+ wrapLine,+ ) where+ import Control.Monad- ( when, filterM, unless, liftM2 )+ ( when, unless, filterM ) import Data.List- ( nub, unfoldr )+ ( nub, unfoldr, isPrefixOf, tails, intersperse )+import Data.Char as Char+ ( toLower, chr, ord )+import Data.Bits+ ( Bits((.|.), (.&.), shiftL, shiftR) ) import System.Directory- ( getDirectoryContents, getCurrentDirectory, doesDirectoryExist+ ( getDirectoryContents, getCurrentDirectory, setCurrentDirectory, doesDirectoryExist , doesFileExist, removeFile ) import System.Environment ( getProgName )+import System.Cmd+ ( rawSystem ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath- ( takeDirectory, takeExtension, (</>), (<.>), pathSeparator )+ ( takeDirectory, splitFileName, splitExtension, normalise+ , (</>), (<.>), pathSeparator )+import System.Directory+ ( copyFile, createDirectoryIfMissing, renameFile, removeDirectoryRecursive ) import System.IO- ( hPutStrLn, stderr, hFlush, stdout, openFile, IOMode(WriteMode) )-import System.IO.Error+ ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode+ , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )+import System.IO.Error as IO.Error ( try )+import qualified Control.Exception as Exception+ ( bracket, bracket_, catch, handle, finally, throwIO ) -import Distribution.Compat.Directory- ( copyFile, findExecutable, createDirectoryIfMissing- , getDirectoryContentsWithoutSpecial, getTemporaryDirectory )-import Distribution.Compat.RawSystem- ( rawSystem )-import Distribution.Compat.Exception- ( bracket )-import Distribution.System- ( OS(..), os )-import Distribution.Version- (showVersion)+import Distribution.Text+ ( display ) import Distribution.Package- (PackageIdentifier(..))+ ( PackageIdentifier )+import Distribution.Version+ (Version(..)) -#if __GLASGOW_HASKELL__ >= 604+#ifdef __GLASGOW_HASKELL__+import Control.Concurrent (forkIO) import Control.Exception (evaluate)-import System.Process (runProcess, waitForProcess)+import System.Process (runInteractiveProcess, waitForProcess) #else import System.Cmd (system)+import System.Directory (getTemporaryDirectory) #endif-import System.IO (hClose) -#if __GLASGOW_HASKELL__ >= 604-import Distribution.Compat.TempFile (openTempFile)+import Distribution.Compat.TempFile (openTempFile, openBinaryTempFile)+import Distribution.Verbosity++-- We only get our own version number when we're building with ourselves+cabalVersion :: Version+#ifdef CABAL_VERSION+cabalVersion = Version [CABAL_VERSION] [] #else-import Distribution.Compat.TempFile (withTempFile)+cabalVersion = error "Cabal was not bootstrapped correctly" #endif-import Distribution.Verbosity -#ifdef DEBUG-import Test.HUnit ((~:), (~=?), Test(..), assertEqual)+cabalBootstrapping :: Bool+#ifdef CABAL_VERSION+cabalBootstrapping = False+#else+cabalBootstrapping = True #endif -- ------------------------------------------------------------------------------- Utils for setup -dieWithLocation :: FilePath -> (Maybe Int) -> String -> IO a-dieWithLocation fname Nothing msg = die (fname ++ ": " ++ msg)-dieWithLocation fname (Just n) msg = die (fname ++ ":" ++ show n ++ ": " ++ msg)+dieWithLocation :: FilePath -> Maybe Int -> String -> IO a+dieWithLocation filename lineno msg =+ die $ normalise filename+ ++ maybe "" (\n -> ":" ++ show n) lineno+ ++ ": " ++ msg die :: String -> IO a die msg = do hFlush stdout pname <- getProgName- hPutStrLn stderr (pname ++ ": " ++ msg)+ hPutStr stderr (wrapText (pname ++ ": " ++ msg)) exitWith (ExitFailure 1) -- | Non fatal conditions that may be indicative of an error or problem.@@ -161,7 +201,7 @@ warn verbosity msg = when (verbosity >= normal) $ do hFlush stdout- hPutStrLn stderr ("Warning: " ++ msg)+ hPutStr stderr (wrapText ("Warning: " ++ msg)) -- | Useful status messages. --@@ -173,8 +213,12 @@ notice :: Verbosity -> String -> IO () notice verbosity msg = when (verbosity >= normal) $- putStrLn msg+ putStr (wrapText msg) +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()+setupMessage verbosity msg pkgid =+ notice verbosity (msg ++ ' ': display pkgid ++ "...")+ -- | More detail on the operation of some action. -- -- We display these messages when the verbosity level is 'verbose'@@ -182,7 +226,7 @@ info :: Verbosity -> String -> IO () info verbosity msg = when (verbosity >= verbose) $- putStrLn msg+ putStr (wrapText msg) -- | Detailed internal debugging information --@@ -191,8 +235,17 @@ debug :: Verbosity -> String -> IO () debug verbosity msg = when (verbosity >= deafening) $- putStrLn msg+ putStr (wrapText msg) +-- | Perform an IO action, catching any IO exceptions and printing an error+-- if one occurs.+chattyTry :: String -- ^ a description of the action we were attempting+ -> IO () -- ^ the action itself+ -> IO ()+chattyTry desc action =+ Exception.catch action $ \exception ->+ putStrLn $ "Error while " ++ desc ++ ": " ++ show exception+ -- ----------------------------------------------------------------------------- -- Helper functions @@ -204,9 +257,17 @@ (v, xs'') -> v : breaks f xs'' --- Wraps a list of words text to a list of lines of a particular width.-wrapText :: Int -> [String] -> [String]-wrapText width = map unwords . wrap 0 []+-- | Wraps text to the default line width. Existing newlines are preserved.+wrapText :: String -> String+wrapText = unlines+ . concatMap (map unwords+ . wrapLine 79+ . words)+ . lines++-- | Wraps a list of words to a list of lines of words of a particular width.+wrapLine :: Int -> [String] -> [[String]]+wrapLine width = wrap 0 [] where wrap :: Int -> [String] -> [String] -> [[String]] wrap 0 [] (w:ws) | length w + 1 > width@@ -238,17 +299,15 @@ rawSystemExit verbosity path args = do printRawCommandAndArgs verbosity path args hFlush stdout- maybeExit $ rawSystem path args---- Exit with the same exitcode if the subcommand fails-rawSystemPathExit :: Verbosity -> String -> [String] -> IO ()-rawSystemPathExit verbosity prog args = do- r <- findExecutable prog- case r of- Nothing -> die ("Cannot find: " ++ prog)- Just path -> rawSystemExit verbosity path args+ exitcode <- rawSystem path args+ unless (exitcode == ExitSuccess) $ do+ debug verbosity $ path ++ " returned " ++ show exitcode+ exitWith exitcode --- Run a command and return its output+-- | Run a command and return its output.+--+-- The output is assumed to be encoded as UTF8.+-- rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String rawSystemStdout verbosity path args = do (output, exitCode) <- rawSystemStdout' verbosity path args@@ -258,34 +317,46 @@ rawSystemStdout' :: Verbosity -> FilePath -> [String] -> IO (String, ExitCode) rawSystemStdout' verbosity path args = do printRawCommandAndArgs verbosity path args- tmpDir <- getTemporaryDirectory -#if __GLASGOW_HASKELL__ >= 604- -- TODO Ideally we'd use runInteractiveProcess and not have to make any- -- silly temp files, however it is not possible to only connect pipes- -- to a subset of the process's stdin/out/err. We really cannot- -- connect to all three since then we'd need threads to pull on stdout- -- and stderr simultaniously to avoid deadlock, and using threads like- -- that would not be portable to Hugs for example.- bracket (liftM2 (,) (openTempFile tmpDir "cmdstdout") (openFile devNull WriteMode))- -- We need to close tmpHandle or the file removal fails on Windows- (\((tmpName, tmpHandle), nullHandle) -> do- hClose tmpHandle- removeFile tmpName- hClose nullHandle)- $ \((tmpName, tmpHandle), nullHandle) -> do- cmdHandle <- runProcess path args Nothing Nothing- Nothing (Just tmpHandle) (Just nullHandle)- exitCode <- waitForProcess cmdHandle- output <- readFile tmpName- evaluate (length output)- return (output, exitCode)+#ifdef __GLASGOW_HASKELL__+ Exception.bracket+ (runInteractiveProcess path args Nothing Nothing)+ (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)+ $ \(_,outh,errh,pid) -> do++ -- We want to process the output as text.+ hSetBinaryMode outh False++ -- fork off a thread to pull on (and discard) the stderr+ -- so if the process writes to stderr we do not block.+ -- NB. do the hGetContents synchronously, otherwise the outer+ -- bracket can exit before this thread has run, and hGetContents+ -- will fail.+ err <- hGetContents errh + forkIO $ do evaluate (length err); return ()++ -- wait for all the output+ output <- hGetContents outh+ evaluate (length output)++ -- wait for the program to terminate+ exitcode <- waitForProcess pid+ unless (exitcode == ExitSuccess) $+ debug verbosity $ path ++ " returned " ++ show exitcode+ ++ if null err then "" else+ " with error message:\n" ++ err++ return (output, exitcode) #else- withTempFile tmpDir "cmdstdout" $ \tmpName -> do+ tmpDir <- getTemporaryDirectory+ withTempFile tmpDir ".cmd.stdout" $ \tmpName tmpHandle -> do+ hClose tmpHandle let quote name = "'" ++ name ++ "'"- exitCode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName- output <- readFile tmpName- length output `seq` return (output, exitCode)+ exitcode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName+ unless (exitcode == ExitSuccess) $+ debug verbosity $ path ++ " returned " ++ show exitcode+ withFileContents tmpName $ \output ->+ length output `seq` return (output, exitcode) #endif -- | Like the unix xargs program. Useful for when we've got very long command@@ -294,7 +365,7 @@ -- -- Use it with either of the rawSystem variants above. For example: -- --- > xargs (32*1024) (rawSystemPathExit verbosity) prog fixedArgs bigArgs+-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs -- xargs :: Int -> ([String] -> IO ()) -> [String] -> [String] -> IO ()@@ -313,51 +384,18 @@ | 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 -- ------------------------------------------------------------ --- |Get the file path for this particular module. In the IO monad--- because it looks for the actual file. Might eventually interface--- with preprocessor libraries in order to correctly locate more--- filenames.--- Returns empty list if no such files exist.--moduleToFilePath :: [FilePath] -- ^search locations- -> String -- ^Module Name- -> [String] -- ^possible suffixes- -> IO [FilePath]--moduleToFilePath pref s possibleSuffixes- = filterM doesFileExist $- concatMap (searchModuleToPossiblePaths s possibleSuffixes) pref- where searchModuleToPossiblePaths :: String -> [String] -> FilePath -> [FilePath]- searchModuleToPossiblePaths s' suffs searchP- = moduleToPossiblePaths searchP s' suffs---- |Like 'moduleToFilePath', but return the location and the rest of--- the path as separate results.-moduleToFilePath2- :: [FilePath] -- ^search locations- -> String -- ^Module Name- -> [String] -- ^possible suffixes- -> IO [(FilePath, FilePath)] -- ^locations and relative names-moduleToFilePath2 locs mname possibleSuffixes- = filterM exists $- [(loc, fname <.> ext) | loc <- locs, ext <- possibleSuffixes]- where- fname = dotToSep mname- exists (loc, relname) = doesFileExist (loc </> relname)---- |Get the possible file paths based on this module name.-moduleToPossiblePaths :: FilePath -- ^search prefix- -> String -- ^module name- -> [String] -- ^possible suffixes- -> [FilePath]-moduleToPossiblePaths searchPref s possibleSuffixes =- let fname = searchPref </> (dotToSep s)- in [fname <.> ext | ext <- possibleSuffixes]- findFile :: [FilePath] -- ^search locations -> FilePath -- ^File Name -> IO FilePath@@ -411,29 +449,15 @@ -> FilePath -- ^Target directory -> [String] -- ^Modules -> [String] -- ^search suffixes- -> Bool -- ^Exit if no such modules- -> Bool -- ^Preserve directory structure -> IO ()-smartCopySources verbosity srcDirs targetDir sources searchSuffixes exitIfNone preserveDirs- = do createDirectoryIfMissingVerbose verbosity True targetDir- allLocations <- mapM moduleToFPErr sources- let copies = [(srcDir </> name,- if preserveDirs - then targetDir </> srcDir </> name- else targetDir </> name) |- (srcDir, name) <- concat allLocations]- -- Create parent directories for everything:- mapM_ (createDirectoryIfMissingVerbose verbosity True) $ nub $- [takeDirectory targetFile | (_, targetFile) <- copies]- -- Put sources into place:- sequence_ [copyFileVerbose verbosity srcFile destFile |- (srcFile, destFile) <- copies]+smartCopySources verbosity srcDirs targetDir sources searchSuffixes+ = mapM moduleToFPErr sources >>= copyFiles verbosity targetDir+ where moduleToFPErr m- = do p <- moduleToFilePath2 srcDirs m searchSuffixes- when (null p && exitIfNone)- (die ("Error: Could not find module: " ++ m- ++ " with any suffix: " ++ (show searchSuffixes)))- return p+ = findFileWithExtension' searchSuffixes srcDirs (dotToSep m)+ >>= maybe notFound return+ where notFound = die $ "Error: Could not find module: " ++ m+ ++ " with any suffix: " ++ show searchSuffixes createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO () createDirectoryIfMissingVerbose verbosity parentsToo dir = do@@ -446,6 +470,40 @@ info verbosity ("copy " ++ src ++ " to " ++ dest) copyFile src dest +-- | Copies a bunch of files to a target directory, preserving the directory+-- structure in the target location. The target directories are created if they+-- do not exist.+--+-- The files are identified by a pair of base directory and a path relative to+-- that base. It is only the relative part that is preserved in the+-- destination.+--+-- For example:+--+-- > copyFiles normal "dist/src"+-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]+--+-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and+-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".+--+-- This operation is not atomic. Any IO failure during the copy (including any+-- missing source files) leaves the target in an unknown state so it is best to+-- use it with a freshly created directory so that it can be simply deleted if+-- anything goes wrong.+--+copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+copyFiles verbosity targetDir srcFiles = do++ -- Create parent directories for everything+ let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles+ mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs++ -- Copy all the files+ sequence_ [ let src = srcBase </> srcFile+ dest = targetDir </> srcFile+ in copyFileVerbose verbosity src dest+ | (srcBase, srcFile) <- srcFiles ]+ -- adaptation of removeDirectoryRecursive copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () copyDirectoryRecursiveVerbose verbosity srcDir destDir = do@@ -465,102 +523,140 @@ getDirectoryContentsWithoutSpecial src >>= mapM_ cp in aux srcDir destDir + where getDirectoryContentsWithoutSpecial =+ fmap (filter (not . flip elem [".", ".."]))+ . getDirectoryContents +-- | Use a temporary filename that doesn't already exist.+--+withTempFile :: FilePath -- ^ Temp dir to create the file in+ -> String -- ^ File name template. See 'openTempFile'.+ -> (FilePath -> Handle -> IO a) -> IO a+withTempFile tmpDir template action =+ Exception.bracket+ (openTempFile tmpDir template)+ (\(name, handle) -> hClose handle >> removeFile name)+ (uncurry action) +-- | Use a temporary directory.+--+-- Use this exact given dir which must not already exist.+--+withTempDirectory :: Verbosity -> FilePath -> IO a -> IO a+withTempDirectory verbosity tmpDir =+ Exception.bracket_+ (createDirectoryIfMissingVerbose verbosity True tmpDir)+ (removeDirectoryRecursive tmpDir) +-- | Gets the contents of a file, but guarantee that it gets closed.+--+-- The file is read lazily but if it is not fully consumed by the action then+-- the remaining input is truncated and the file is closed.+--+withFileContents :: FilePath -> (String -> IO a) -> IO a+withFileContents name action =+ Exception.bracket (openFile name ReadMode) hClose+ (\hnd -> hGetContents hnd >>= action)++-- | Writes a file atomically.+--+-- The file is either written sucessfully or an IO exception is raised and+-- the original file is left unchanged.+--+-- * Warning: On Windows this operation is very nearly but not quite atomic.+-- See below.+--+-- On Posix it works by writing a temporary file and atomically renaming over+-- the top any pre-existing target file with the temporary one.+--+-- On Windows it is not possible to rename over an existing file so the target+-- file has to be deleted before the temporary file is renamed to the target.+-- Therefore there is a race condition between the existing file being removed+-- and the temporary file being renamed. Another thread could write to the+-- target or change the permission on the target directory between the deleting+-- and renaming steps. An exception would be raised but the target file would+-- either no longer exist or have the content as written by the other thread.+--+-- On windows it is not possible to delete a file that is open by a process.+-- This case will give an IO exception but the atomic property is not affected.+--+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+ hClose tmpHandle+#if mingw32_HOST_OS || mingw32_TARGET_OS+ renameFile tmpFile targetFile+ -- If the targetFile exists then renameFile will fail+ `Exception.catch` \err -> do+ exists <- doesFileExist targetFile+ if exists+ then do removeFile targetFile+ -- Big fat hairy race condition+ renameFile tmpFile targetFile+ -- If the removeFile succeeds and the renameFile fails+ -- then we've lost the atomic property.+ else Exception.throwIO err+#else+ renameFile tmpFile targetFile+#endif+ where+ template = targetName <.> "tmp"+ targetDir | null targetDir_ = currentDir+ | otherwise = targetDir_+ --TODO: remove this when takeDirectory/splitFileName is fixed+ -- to always return a valid dir+ (targetDir_,targetName) = splitFileName targetFile++ -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific. -- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) currentDir :: FilePath currentDir = "." -mkLibName :: FilePath -- ^file Prefix- -> String -- ^library name.- -> String-mkLibName pref lib = pref </> ("libHS" ++ lib ++ ".a")--mkProfLibName :: FilePath -- ^file Prefix- -> String -- ^library name.- -> String-mkProfLibName pref lib = mkLibName pref (lib++"_p")---- Implement proper name mangling for dynamical shared objects--- libHS<packagename>-<compilerFlavour><compilerVersion>--- e.g. libHSbase-2.1-ghc6.6.1.so-mkSharedLibName :: FilePath -- ^file Prefix- -> String -- ^library name.- -> PackageIdentifier -- ^package identifier of the compiler- -> String-mkSharedLibName pref lib (PackageIdentifier compilerName compilerVersion)- = pref </> ("libHS" ++ lib ++ "-" ++ compiler) <.> dllExtension- where compiler = compilerName ++ showVersion compilerVersion- -- ------------------------------------------------------------ -- * Finding the description file -- ------------------------------------------------------------ -oldDescFile :: String-oldDescFile = "Setup.description"--cabalExt :: String-cabalExt = "cabal"--buildInfoExt :: String-buildInfoExt = "buildinfo"---- > matchesDescFile "blah.Cabal"--- > not $ matchesDescFile "blag.bleg"-matchesDescFile :: FilePath -> Bool-matchesDescFile p = (takeExtension p) == '.':cabalExt- || p == oldDescFile--noDesc :: IO a-noDesc = die $ "No description file found, please create a cabal-formatted description file with the name <pkgname>." ++ cabalExt--multiDesc :: [String] -> IO a-multiDesc l = die $ "Multiple description files found. Please use only one of : "- ++ show (filter (/= oldDescFile) l)---- |A list of possibly correct description files. Should be pre-filtered.-descriptionCheck :: Verbosity -> [FilePath] -> IO FilePath-descriptionCheck _ [] = noDesc-descriptionCheck verbosity [x]- | x == oldDescFile- = do warn verbosity $ "The filename \"Setup.description\" is deprecated, please move to <pkgname>." ++ cabalExt- return x- | matchesDescFile x = return x- | otherwise = noDesc-descriptionCheck verbosity [x,y]- | x == oldDescFile- = do warn verbosity $ "The filename \"Setup.description\" is deprecated. Please move out of the way. Using \""- ++ y ++ "\""- return y- | y == oldDescFile- = do warn verbosity $ "The filename \"Setup.description\" is deprecated. Please move out of the way. Using \""- ++ x ++ "\""- return x-- | otherwise = multiDesc [x,y]-descriptionCheck _ l = multiDesc l- -- |Package description file (/pkgname/@.cabal@) defaultPackageDesc :: Verbosity -> IO FilePath-defaultPackageDesc verbosity- = getCurrentDirectory >>= findPackageDesc verbosity+defaultPackageDesc _verbosity = findPackageDesc currentDir -- |Find a package description file in the given directory. Looks for -- @.cabal@ files.-findPackageDesc :: Verbosity -- ^Verbosity- -> FilePath -- ^Where to look- -> IO FilePath -- <pkgname>.cabal-findPackageDesc verbosity p- = do ls <- getDirectoryContents p- let descs = filter matchesDescFile ls- descriptionCheck verbosity descs+findPackageDesc :: FilePath -- ^Where to look+ -> IO FilePath -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+ -- file we filter to exclude dirs and null base file names:+ cabalFiles <- filterM doesFileExist+ [ dir </> file+ | file <- files+ , let (name, ext) = splitExtension file+ , not (null name) && ext == ".cabal" ]+ case cabalFiles of+ [] -> noDesc+ [cabalFile] -> return cabalFile+ multiple -> multiDesc multiple + where+ noDesc :: IO a+ noDesc = die $ "No cabal file found.\n"+ ++ "Please create a package description file <pkgname>.cabal"++ multiDesc :: [String] -> IO a+ multiDesc l = die $ "Multiple cabal files found.\n"+ ++ "Please use only one of: "+ ++ show l+ -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath)-defaultHookedPackageDesc = getCurrentDirectory >>= findHookedPackageDesc+defaultHookedPackageDesc = findHookedPackageDesc currentDir -- |Find auxiliary package information in the given directory. -- Looks for @.buildinfo@ files.@@ -568,78 +664,125 @@ :: FilePath -- ^Directory to search -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc dir = do- ns <- getDirectoryContents dir- case [dir </> n |- n <- ns, takeExtension n == '.':buildInfoExt] of+ files <- getDirectoryContents dir+ buildInfoFiles <- filterM doesFileExist+ [ dir </> file+ | file <- files+ , 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) +buildInfoExt :: String+buildInfoExt = ".buildinfo"+ -- --------------------------------------------------------------- * Platform file extensions--- ------------------------------------------------------------ +-- * Unicode stuff+-- ------------------------------------------------------------ --- ToDo: This should be determined via autoconf (AC_EXEEXT)--- | Extension for executable files--- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)-exeExtension :: String-exeExtension = case os of- Windows _ -> "exe"- _ -> ""+-- This is a modification of the UTF8 code from gtk2hs and the+-- utf8-string package. --- ToDo: This should be determined via autoconf (AC_OBJEXT)--- | Extension for object files. For GHC and NHC the extension is @\"o\"@.--- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.-objExtension :: String-objExtension = "o"+fromUTF8 :: String -> String+fromUTF8 [] = []+fromUTF8 (c:cs)+ | c <= '\x7F' = c : fromUTF8 cs+ | c <= '\xBF' = replacementChar : fromUTF8 cs+ | c <= '\xDF' = twoBytes c cs+ | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF)+ | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7)+ | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3)+ | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)+ | otherwise = replacementChar : fromUTF8 cs+ where+ twoBytes c0 (c1:cs')+ | ord c1 .&. 0xC0 == 0x80+ = let d = ((ord c0 .&. 0x1F) `shiftL` 6)+ .|. (ord c1 .&. 0x3F)+ in if d >= 0x80+ then chr d : fromUTF8 cs'+ else replacementChar : fromUTF8 cs'+ twoBytes _ cs' = replacementChar : fromUTF8 cs' --- | Extension for dynamically linked (or shared) libraries--- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)-dllExtension :: String-dllExtension = case os of- Windows _ -> "dll"- OSX -> "dylib"- _ -> "so"+ moreBytes :: Int -> Int -> [Char] -> Int -> [Char]+ moreBytes 1 overlong cs' acc+ | overlong <= acc && acc <= 0x10FFFF+ && (acc < 0xD800 || 0xDFFF < acc)+ && (acc < 0xFFFE || 0xFFFF < acc)+ = chr acc : fromUTF8 cs' -devNull :: FilePath-devNull = case os of- Windows _ -> "NUL"- _ -> "/dev/null"+ | otherwise+ = replacementChar : fromUTF8 cs' + moreBytes byteCount overlong (cn:cs') acc+ | ord cn .&. 0xC0 == 0x80+ = moreBytes (byteCount-1) overlong cs'+ ((acc `shiftL` 6) .|. ord cn .&. 0x3F)++ moreBytes _ _ cs' _+ = replacementChar : fromUTF8 cs'++ replacementChar = '\xfffd'++toUTF8 :: String -> String+toUTF8 [] = []+toUTF8 (c:cs)+ | c <= '\x07F' = c+ : toUTF8 cs+ | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))+ : chr (0x80 .|. (w .&. 0x3F))+ : toUTF8 cs+ | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12))+ : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))+ : chr (0x80 .|. (w .&. 0x3F))+ : toUTF8 cs+ | otherwise = chr (0xf0 .|. (w `shiftR` 18))+ : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F))+ : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))+ : chr (0x80 .|. (w .&. 0x3F))+ : toUTF8 cs+ where w = ord c++-- | Reads a UTF8 encoded text file as a Unicode String+--+-- Reads lazily using ordinary 'readFile'.+--+readUTF8File :: FilePath -> IO String+readUTF8File f = fmap fromUTF8 . hGetContents =<< openBinaryFile f ReadMode++-- | Reads a UTF8 encoded text file as a Unicode String+--+-- Same behaviour as 'withFileContents'.+--+withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a+withUTF8FileContents name action =+ Exception.bracket (openBinaryFile name ReadMode) hClose+ (\hnd -> hGetContents hnd >>= action . fromUTF8)++-- | Writes a Unicode String as a UTF8 encoded text file.+--+-- Uses 'writeFileAtomic', so provides the same guarantees.+--+writeUTF8File :: FilePath -> String -> IO ()+writeUTF8File path = writeFileAtomic path . toUTF8+ -- --------------------------------------------------------------- * Testing+-- * Common utils -- ------------------------------------------------------------ -#ifdef DEBUG-hunitTests :: [Test]-hunitTests- = let suffixes = ["hs", "lhs"]- in [TestCase $- do mp1 <- moduleToFilePath [""] "Distribution.Simple.Build" suffixes --exists- mp2 <- moduleToFilePath [""] "Foo.Bar" suffixes -- doesn't exist- assertEqual "existing not found failed"- ["Distribution" </> "Simple" </> "Build.hs"] mp1- assertEqual "not existing not nothing failed" [] mp2,+equating :: Eq a => (b -> a) -> b -> b -> Bool+equating p x y = p x == p y - "moduleToPossiblePaths 1" ~: "failed" ~:- ["Foo" </> "Bar" </> "Bang.hs","Foo" </> "Bar" </> "Bang.lhs"]- ~=? (moduleToPossiblePaths "" "Foo.Bar.Bang" suffixes),- "moduleToPossiblePaths2 " ~: "failed" ~:- (moduleToPossiblePaths "" "Foo" suffixes) ~=? ["Foo.hs", "Foo.lhs"],- TestCase (do files <- filesWithExtensions "." "cabal"- assertEqual "filesWithExtensions" "Cabal.cabal" (head files))- ]+comparing :: Ord a => (b -> a) -> b -> b -> Ordering+comparing p x y = p x `compare` p y --- |Might want to make this more generic some day, with regexps--- or something.-filesWithExtensions :: FilePath -- ^Directory to look in- -> String -- ^The extension- -> IO [FilePath] {- ^The file names (not full- path) of all the files with this- extension in this directory. -}-filesWithExtensions dir extension - = do allFiles <- getDirectoryContents dir- return $ filter hasExt allFiles- where- hasExt f = takeExtension f == '.':extension-#endif+isInfixOf :: String -> String -> Bool+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)++intercalate :: [a] -> [[a]] -> [a]+intercalate sep = concat . intersperse sep++lowercase :: String -> String+lowercase = map Char.toLower
Distribution/System.hs view
@@ -1,14 +1,132 @@-module Distribution.System where+module Distribution.System (+ -- * Operating System+ OS(..),+ buildOS, -import qualified System.Info+ -- * Machine Architecture+ Arch(..),+ buildArch,+ ) where -data OS = Linux | Windows Windows | OSX | Solaris | Other String-data Windows = MingW+import qualified System.Info (os, arch)+import qualified Data.Char as Char (toLower, isAlphaNum) -os :: OS-os = case System.Info.os of- "linux" -> Linux- "mingw32" -> Windows MingW- "darwin" -> OSX- "solaris2" -> Solaris- other -> Other other+import Distribution.Text (Text(..), display)+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp++-- | How strict to be when classifying strings into the 'OS' and 'Arch' enums.+--+-- The reason we have multiple ways to do the classification is because there+-- are two situations where we need to do it.+--+-- For parsing os and arch names in .cabal files we really want everyone to be+-- referring to the same or or arch by the same name. Variety is not a virtue+-- in this case. We don't mind about case though.+--+-- For the System.Info.os\/arch different Haskell implementations use different+-- names for the same or\/arch. Also they tend to distinguish versions of an+-- os\/arch which we just don't care about.+--+-- The 'Compat' classification allows us to recognise aliases that are already+-- in common use but it allows us to distinguish them from the canonical name+-- which enables us to warn about such deprecated aliases.+--+data ClassificationStrictness = Permissive | Compat | Strict++-- ------------------------------------------------------------+-- * Operating System+-- ------------------------------------------------------------++data OS = Linux | Windows | OSX+ | FreeBSD | OpenBSD | NetBSD+ | Solaris | AIX | HPUX | IRIX+ | OtherOS String+ deriving (Eq, Ord, Show, Read)++knownOSs :: [OS]+knownOSs = [Linux, Windows, OSX+ ,FreeBSD, OpenBSD, NetBSD+ ,Solaris, AIX, HPUX, IRIX]++osAliases :: ClassificationStrictness -> OS -> [String]+osAliases Permissive Windows = ["mingw32", "cygwin32"]+osAliases Compat Windows = ["mingw32", "win32"]+osAliases _ OSX = ["darwin"]+osAliases Permissive FreeBSD = ["kfreebsdgnu"]+osAliases Permissive Solaris = ["solaris2"]+osAliases _ _ = []++instance Text OS where+ disp (OtherOS name) = Disp.text name+ disp other = Disp.text (lowercase (show other))++ parse = fmap (classifyOS Compat) ident++classifyOS :: ClassificationStrictness -> String -> OS+classifyOS strictness s =+ case lookup (lowercase s) osMap of+ Just os -> os+ Nothing -> OtherOS s+ where+ osMap = [ (name, os)+ | os <- knownOSs+ , name <- display os : osAliases strictness os ]++buildOS :: OS+buildOS = classifyOS Permissive System.Info.os++-- ------------------------------------------------------------+-- * Machine Architecture+-- ------------------------------------------------------------++data Arch = I386 | X86_64 | PPC | PPC64 | Sparc+ | Arm | Mips | SH+ | IA64 | S390 + | Alpha | Hppa | Rs6000+ | M68k | Vax+ | OtherArch String+ deriving (Eq, Ord, Show, Read)++knownArches :: [Arch]+knownArches = [I386, X86_64, PPC, PPC64, Sparc+ ,Arm, Mips, SH+ ,IA64, S390 + ,Alpha, Hppa, Rs6000+ ,M68k, Vax]++archAliases :: ClassificationStrictness -> Arch -> [String]+archAliases Strict _ = []+archAliases Compat _ = []+archAliases _ PPC = ["powerpc"]+archAliases _ PPC64 = ["powerpc64"]+archAliases _ Sparc = ["sparc64", "sun4"]+archAliases _ Mips = ["mipsel", "mipseb"]+archAliases _ Arm = ["armeb", "armel"]+archAliases _ _ = []++instance Text Arch where+ disp (OtherArch name) = Disp.text name+ disp other = Disp.text (lowercase (show other))++ parse = fmap (classifyArch Strict) ident++classifyArch :: ClassificationStrictness -> String -> Arch+classifyArch strictness s =+ case lookup (lowercase s) archMap of+ Just arch -> arch+ Nothing -> OtherArch s+ where+ archMap = [ (name, arch)+ | arch <- knownArches+ , name <- display arch : archAliases strictness arch ]++buildArch :: Arch+buildArch = classifyArch Permissive System.Info.arch++ident :: Parse.ReadP r String+ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')+ --TODO: probably should disallow starting with a number++lowercase :: String -> String+lowercase = map Char.toLower
+ Distribution/Text.hs view
@@ -0,0 +1,50 @@+module Distribution.Text (+ Text(..),+ display,+ simpleParse,+ ) where++import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp++import Data.Version (Version(Version))+import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace)++class Text a where+ disp :: a -> Disp.Doc+ parse :: Parse.ReadP r a++display :: Text a => a -> String+display = Disp.render . disp++simpleParse :: Text a => String -> Maybe a+simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str+ , all Char.isSpace s ] of+ [] -> Nothing+ (p:_) -> Just p++-- -----------------------------------------------------------------------------+-- Instances for types from the base package++instance Text Bool where+ disp = Disp.text . show+ parse = Parse.choice [ (Parse.string "True" Parse.++++ Parse.string "true") >> return True+ , (Parse.string "False" Parse.++++ Parse.string "false") >> return False ]++instance Text Version where+ disp (Version branch _tags) -- Do not display the tags+ = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))++ parse = do+ branch <- Parse.sepBy1 digits (Parse.char '.')+ tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)+ return (Version branch tags)+ 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))
Distribution/Verbosity.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp -fglasgow-exts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Verbosity@@ -51,9 +50,10 @@ ) where import Data.List (elemIndex)+import Distribution.ReadE data Verbosity = Silent | Normal | Verbose | Deafening- deriving (Show, Eq, Ord)+ deriving (Show, Eq, Ord, Enum, Bounded) -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity@@ -79,7 +79,7 @@ moreVerbose Deafening = Deafening lessVerbose :: Verbosity -> Verbosity-lessVerbose Deafening = Verbose+lessVerbose Deafening = Deafening lessVerbose Verbose = Normal lessVerbose Normal = Silent lessVerbose Silent = Silent@@ -91,16 +91,15 @@ intToVerbosity 3 = Just Deafening intToVerbosity _ = Nothing -flagToVerbosity :: Maybe String -> Verbosity-flagToVerbosity Nothing = verbose -- A "-v" flag is equivalent to "-v2"-flagToVerbosity (Just s)- = case reads s of+flagToVerbosity :: ReadE Verbosity+flagToVerbosity = ReadE $ \s ->+ case reads s of [(i, "")] -> case intToVerbosity i of- Just v -> v- Nothing -> error ("Bad verbosity: " ++ show i ++- ". Valid values are 0..3")- _ -> error ("Can't parse verbosity " ++ s)+ Just v -> Right v+ Nothing -> Left ("Bad verbosity: " ++ show i +++ ". Valid values are 0..3")+ _ -> Left ("Can't parse verbosity " ++ s) showForCabal, showForGHC :: Verbosity -> String
Distribution/Version.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -cpp -fglasgow-exts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Version@@ -44,161 +43,26 @@ module Distribution.Version ( -- * Package versions Version(..),- showVersion,- readVersion,- parseVersion, -- * Version ranges- VersionRange(..), + VersionRange(..), notThisVersion, orLaterVersion, orEarlierVersion, betweenVersionsInclusive, withinRange,- showVersionRange,- parseVersionRange, isAnyVersion, - -- * Dependencies- Dependency(..),--#ifdef DEBUG- hunitTests-#endif+ -- * Deprecated compat stuff+ showVersion,+ parseVersion, ) where -#if __HUGS__ || __GLASGOW_HASKELL__ >= 603-import Data.Version ( Version(..), showVersion, parseVersion )-#endif--import Control.Monad ( liftM )-import Data.Char ( isSpace )-import Data.Maybe ( listToMaybe )--import Distribution.Compat.ReadP--#ifdef DEBUG-import Test.HUnit-#endif---- -------------------------------------------------------------------------------- The Version type--#if ( __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603 ) || __NHC__---- Code copied from Data.Version in GHC 6.3+ :---- These #ifdefs are necessary because this code might be compiled as--- part of ghc/lib/compat, and hence might be compiled by an older version--- of GHC. In which case, we might need to pick up ReadP from --- Distribution.Compat.ReadP, because the version in --- Text.ParserCombinators.ReadP doesn't have all the combinators we need.-#if __GLASGOW_HASKELL__ <= 602 || __NHC__-import Distribution.Compat.ReadP-#else-import Text.ParserCombinators.ReadP-#endif--#if __GLASGOW_HASKELL__ < 602-import Data.Dynamic ( Typeable(..), TyCon, mkTyCon, mkAppTy )-#else-import Data.Typeable ( Typeable )-#endif--import Data.List ( intersperse, sort )-import Data.Char ( isDigit, isAlphaNum )--{- |-A 'Version' represents the version of a software entity. --An instance of 'Eq' is provided, which implements exact equality-modulo reordering of the tags in the 'versionTags' field.--An instance of 'Ord' is also provided, which gives lexicographic-ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2,-etc.). This is expected to be sufficient for many uses, but note that-you may need to use a more specific ordering for your versioning-scheme. For example, some versioning schemes may include pre-releases-which have tags @"pre1"@, @"pre2"@, and so on, and these would need to-be taken into account when determining ordering. In some cases, date-ordering may be more appropriate, so the application would have to-look for @date@ tags in the 'versionTags' field and compare those.-The bottom line is, don't always assume that 'compare' and other 'Ord'-operations are the right thing for every 'Version'.--Similarly, concrete representations of versions may differ. One-possible concrete representation is provided (see 'showVersion' and-'parseVersion'), but depending on the application a different concrete-representation may be more appropriate.--}-data Version = - Version { versionBranch :: [Int],- -- ^ The numeric branch for this version. This reflects the- -- fact that most software versions are tree-structured; there- -- is a main trunk which is tagged with versions at various- -- points (1,2,3...), and the first branch off the trunk after- -- version 3 is 3.1, the second branch off the trunk after- -- version 3 is 3.2, and so on. The tree can be branched- -- arbitrarily, just by adding more digits.- -- - -- We represent the branch as a list of 'Int', so- -- version 3.2.1 becomes [3,2,1]. Lexicographic ordering- -- (i.e. the default instance of 'Ord' for @[Int]@) gives- -- the natural ordering of branches.-- versionTags :: [String] -- really a bag- -- ^ A version can be tagged with an arbitrary list of strings.- -- The interpretation of the list of tags is entirely dependent- -- on the entity that this version applies to.- }- deriving (Read,Show-#if __GLASGOW_HASKELL__ >= 602- ,Typeable-#endif- )--#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 602-versionTc :: TyCon-versionTc = mkTyCon "Version"--instance Typeable Version where- typeOf _ = mkAppTy versionTc []-#endif--instance Eq Version where- v1 == v2 = versionBranch v1 == versionBranch v2 - && sort (versionTags v1) == sort (versionTags v2)- -- tags may be in any order--instance Ord Version where- v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2---- -------------------------------------------------------------------------------- A concrete representation of 'Version'---- | Provides one possible concrete representation for 'Version'. For--- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' --- @= ["tag1","tag2"]@, the output will be @1.2.3-tag1-tag2@.----showVersion :: Version -> String-showVersion (Version branch tags)- = concat (intersperse "." (map show branch)) ++ - concatMap ('-':) tags---- | A parser for versions in the format produced by 'showVersion'.----#if __GLASGOW_HASKELL__ <= 602-parseVersion :: ReadP r Version-#else-parseVersion :: ReadP Version-#endif-parseVersion = do branch <- sepBy1 (liftM read $ munch1 isDigit) (char '.')- tags <- many (char '-' >> munch1 isAlphaNum)- return Version{versionBranch=branch, versionTags=tags}--#endif+import Data.Version ( Version(..) ) -readVersion :: String -> Maybe Version-readVersion str =- listToMaybe [ r | (r,s) <- readP_to_S parseVersion str, all isSpace s ]+import Distribution.Text ( Text(..), display )+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP ((+++))+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>), (<+>)) -- ----------------------------------------------------------------------------- -- Version ranges@@ -220,6 +84,9 @@ isAnyVersion AnyVersion = True isAnyVersion _ = False +notThisVersion :: Version -> VersionRange+notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)+ orLaterVersion :: Version -> VersionRange orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) @@ -248,132 +115,57 @@ withinRange v1 (IntersectVersionRanges v2 v3) = v1 `withinRange` v2 && v1 `withinRange` v3 -showVersionRange :: VersionRange -> String-showVersionRange AnyVersion = "-any"-showVersionRange (ThisVersion v) = '=' : '=' : showVersion v-showVersionRange (LaterVersion v) = '>' : showVersion v-showVersionRange (EarlierVersion v) = '<' : showVersion v-showVersionRange (UnionVersionRanges (ThisVersion v1) (LaterVersion v2))- | v1 == v2 = '>' : '=' : showVersion v1-showVersionRange (UnionVersionRanges (LaterVersion v2) (ThisVersion v1))- | v1 == v2 = '>' : '=' : showVersion v1-showVersionRange (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2))- | v1 == v2 = '<' : '=' : showVersion v1-showVersionRange (UnionVersionRanges (EarlierVersion v2) (ThisVersion v1))- | v1 == v2 = '<' : '=' : showVersion v1-showVersionRange (UnionVersionRanges r1 r2) - = showVersionRange r1 ++ "||" ++ showVersionRange r2-showVersionRange (IntersectVersionRanges r1 r2) - = showVersionRange r1 ++ "&&" ++ showVersionRange r2---- --------------------------------------------------------------- * Package dependencies--- --------------------------------------------------------------data Dependency = Dependency String VersionRange- deriving (Read, Show, Eq)---- --------------------------------------------------------------- * Parsing--- ------------------------------------------------------------+instance Text VersionRange where+ disp AnyVersion = Disp.text "-any"+ disp (ThisVersion v) = Disp.text "==" <> disp v+ disp (LaterVersion v) = Disp.char '>' <> disp v+ disp (EarlierVersion v) = Disp.char '<' <> disp v+ disp (UnionVersionRanges (ThisVersion v1) (LaterVersion v2))+ | v1 == v2 = Disp.text ">=" <> disp v1+ disp (UnionVersionRanges (LaterVersion v2) (ThisVersion v1))+ | v1 == v2 = Disp.text ">=" <> disp v1+ disp (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2))+ | v1 == v2 = Disp.text "<=" <> disp v1+ disp (UnionVersionRanges (EarlierVersion v2) (ThisVersion v1))+ | v1 == v2 = Disp.text "<=" <> disp v1+ disp (UnionVersionRanges r1 r2)+ = disp r1 <+> Disp.text "||" <+> disp r2+ disp (IntersectVersionRanges r1 r2)+ = disp r1 <+> Disp.text "&&" <+> disp r2 --- ------------------------------------------------------------parseVersionRange :: ReadP r VersionRange-parseVersionRange = do- f1 <- factor- skipSpaces- (do- string "||"- skipSpaces- f2 <- factor- return (UnionVersionRanges f1 f2)- +++- do - string "&&"- skipSpaces- f2 <- factor- return (IntersectVersionRanges f1 f2)- +++- return f1)- where - factor = choice ((string "-any" >> return AnyVersion) :+ parse = do+ f1 <- factor+ Parse.skipSpaces+ (do+ Parse.string "||"+ Parse.skipSpaces+ f2 <- factor+ return (UnionVersionRanges f1 f2)+ ++++ 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)- parseRangeOp (s,f) = string s >> skipSpaces >> liftM f parseVersion+ parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse rangeOps = [ ("<", EarlierVersion), ("<=", orEarlierVersion), (">", LaterVersion), (">=", orLaterVersion), ("==", ThisVersion) ] -#ifdef DEBUG--- --------------------------------------------------------------- * Testing--- ---------------------------------------------------------------- |Simple version parser wrapper-doVersionParse :: String -> Either String Version-doVersionParse input = case results of- [y] -> Right y- [] -> Left "No parse"- _ -> Left "Ambigous parse"- where results = [ x | (x,"") <- readP_to_S parseVersion input ]--branch1 :: [Int]-branch1 = [1]--branch2 :: [Int]-branch2 = [1,2]--branch3 :: [Int]-branch3 = [1,2,3]--release1 :: Version-release1 = Version{versionBranch=branch1, versionTags=[]}--release2 :: Version-release2 = Version{versionBranch=branch2, versionTags=[]}--release3 :: Version-release3 = Version{versionBranch=branch3, versionTags=[]}--hunitTests :: [Test]-hunitTests- = [- "released version 1" ~: "failed"- ~: (Right $ release1) ~=? doVersionParse "1",- "released version 3" ~: "failed"- ~: (Right $ release3) ~=? doVersionParse "1.2.3",+-- ---------------------------------------------------------------------------+-- Deprecated compat stuff - "range comparison LaterVersion 1" ~: "failed"- ~: True- ~=? release3 `withinRange` (LaterVersion release2),- "range comparison LaterVersion 2" ~: "failed"- ~: False- ~=? release2 `withinRange` (LaterVersion release3),- "range comparison EarlierVersion 1" ~: "failed"- ~: True- ~=? release3 `withinRange` (LaterVersion release2),- "range comparison EarlierVersion 2" ~: "failed"- ~: False- ~=? release2 `withinRange` (LaterVersion release3),- "range comparison orLaterVersion 1" ~: "failed"- ~: True- ~=? release3 `withinRange` (orLaterVersion release3),- "range comparison orLaterVersion 2" ~: "failed"- ~: True- ~=? release3 `withinRange` (orLaterVersion release2),- "range comparison orLaterVersion 3" ~: "failed"- ~: False- ~=? release2 `withinRange` (orLaterVersion release3),- "range comparison orEarlierVersion 1" ~: "failed"- ~: True- ~=? release2 `withinRange` (orEarlierVersion release2),- "range comparison orEarlierVersion 2" ~: "failed"- ~: True- ~=? release2 `withinRange` (orEarlierVersion release3),- "range comparison orEarlierVersion 3" ~: "failed"- ~: False- ~=? release3 `withinRange` (orEarlierVersion release2)- ]-#endif+{-# DEPRECATED showVersion "use the Text class instead" #-}+showVersion :: Version -> String+showVersion = display +{-# DEPRECATED parseVersion "use the Text class instead" #-}+parseVersion :: Parse.ReadP r Version+parseVersion = parse
Language/Haskell/Extension.hs view
@@ -41,15 +41,29 @@ module Language.Haskell.Extension ( Extension(..),+ knownExtensions ) 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)+import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))+ -- ------------------------------------------------------------ -- * Extension -- ------------------------------------------------------------ --- NB: if you add a constructor to 'Extension', be sure also to--- add it to Distribution.Compiler.extensionsTo_X_Flag--- (where X is each compiler)+-- Note: if you add a new 'Extension':+--+-- * also add it to the Distribution.Simple.X.languageExtensions lists+-- (where X is each compiler: GHC, JHC, Hugs, NHC)+--+-- * also to the 'knownExtensions' list below.+--+-- * If the first character of the new extension is outside the range 'A' - 'U'+-- (ie 'V'-'Z' or any non-uppercase-alphabetical char) then update the bounds+-- of the 'extensionTable' below. -- |This represents language extensions beyond Haskell 98 that are -- supported by some implementations, usually in some special mode.@@ -110,4 +124,97 @@ | UnboxedTuples | DeriveDataTypeable | ConstrainedClassMethods++ | UnknownExtension String deriving (Show, Read, Eq)++knownExtensions :: [Extension]+knownExtensions =+ [ OverlappingInstances+ , UndecidableInstances+ , IncoherentInstances+ , RecursiveDo+ , ParallelListComp+ , MultiParamTypeClasses+ , NoMonomorphismRestriction+ , FunctionalDependencies+ , Rank2Types+ , RankNTypes+ , PolymorphicComponents+ , ExistentialQuantification+ , ScopedTypeVariables+ , ImplicitParams+ , FlexibleContexts+ , FlexibleInstances+ , EmptyDataDecls+ , CPP++ , KindSignatures+ , BangPatterns+ , TypeSynonymInstances+ , TemplateHaskell+ , ForeignFunctionInterface+ , Arrows+ , Generics+ , NoImplicitPrelude+ , NamedFieldPuns+ , PatternGuards+ , GeneralizedNewtypeDeriving++ , ExtensibleRecords+ , RestrictedTypeSynonyms+ , HereDocuments+ , MagicHash+ , TypeFamilies+ , StandaloneDeriving++ , UnicodeSyntax+ , PatternSignatures+ , UnliftedFFITypes+ , LiberalTypeSynonyms+ , TypeOperators+--PArr -- not ready yet, and will probably be renamed to ParallelArrays+ , RecordWildCards+ , RecordPuns+ , DisambiguateRecordFields+ , OverloadedStrings+ , GADTs+ , NoMonoPatBinds+ , RelaxedPolyRec+ , ExtendedDefaultRules+ , UnboxedTuples+ , DeriveDataTypeable+ , ConstrainedClassMethods+ ]++instance Text Extension where+ disp (UnknownExtension other) = Disp.text other+ disp other = Disp.text (show other)++ parse = do+ extension <- Parse.munch1 Char.isAlphaNum+ return (classifyExtension extension)++-- | 'read' for 'Extension's is really really slow so for the Text instance+-- what we do is make a simple table indexed off the first letter in the+-- extension name. The extension names actually cover the range @'A'-'U'@+-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do+-- a linear search within each bucket.+--+-- This gives an order of magnitude improvement in parsing speed, and it'll+-- also allow us to do case insensitive matches in future if we prefer.+--+classifyExtension :: String -> Extension+classifyExtension string@(c:_)+ | inRange (bounds extensionTable) c+ = case lookup string (extensionTable ! c) of+ Just extension -> extension+ Nothing -> UnknownExtension string+classifyExtension string = UnknownExtension string++extensionTable :: Array Char [(String, Extension)]+extensionTable =+ accumArray (flip (:)) [] ('A', 'U')+ [ (head str, (str, extension))+ | extension <- knownExtensions+ , let str = show extension ]
+ README view
@@ -0,0 +1,105 @@+[Cabal home page](http://www.haskell.org/cabal/)+++Installing as a user (no root or administer access)+===================================================++ ghc --make Setup+ ./Setup configure --user+ ./Setup build+ ./Setup install++This will install into `$HOME/.cabal/` or the equivalent on Windows.+If you want to install elsewhere use the `--prefix=` flag at the+configure step.+++Installing as root / Administrator+==================================++ ghc --make Setup+ ./Setup configure+ ./Setup build+ sudo ./Setup install++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.+++Working with older versions of GHC and Cabal+============================================++It is recommended just to leave any pre-existing version of Cabal+installed. In particular it is *essential* to keep the version that+came with GHC itself since other installed packages need it (eg the+"ghc" api package).++Prior to GHC 6.4.2 however, GHC didn't deal particularly well with+having multiple versions of packages installed at once. So if you+are using GHC 6.4.1 or older and you have an older version of Cabal+installed, you probably just want to remove it:++ ghc-pkg unregister Cabal++or if you had Cabal installed just for your user account then:++ ghc-pkg unregister Cabal --user+++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+problems are with Cabal and Hackage. You probably have a favourite+Cabal bug or limitation. Take a look at our [bug tracker]. Make sure+the problem is reported there and properly described. Comment on the+ticket to tell us how much of a problem the bug is for you. Add+yourself to the ticket's cc list so we can discuss requirements and+keep you informed on progress. For feature requests it is very+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+=======++You can get the code from the web page; the version control system we+use is very open and welcoming to new developers.++You can get the main development branch:++> darcs get --partial http://darcs.haskell.org/cabal++and you can get the stable 1.4 branch:++> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.4+++Credits+=======++Cabal Coders (in alphabetical order):++- Krasimir Angelov+- Bjorn Bringert+- Duncan Coutts+- Isaac Jones+- David Himmelstrup (Lemmih)+- Simon Marlow+- Ross Patterson+- Thomas Schilling+- Martin Sjögren+- Malcolm Wallace+- and nearly 30 other people have contributed occasional patches++Cabal spec:++- Isaac Jones+- Simon Marlow+- Ross Patterson+- Simon Peyton Jones+- Malcolm Wallace
+ changelog view
@@ -0,0 +1,256 @@+-*-change-log-*-++1.5.x (current development version)++1.4.0.0 Duncan Coutts <duncan@haskell.org> June 2008+ * Rewritten command line handling support+ * Command line completion with bash+ * Better support for Haddock 2+ * Improved support for nhc98+ * Removed support for ghc-6.2+ * Haddock markup in .lhs files now supported+ * Default colour scheme for highlighted source code+ * Default prefix for --user installs is now $HOME/.cabal+ * All .cabal files are treaded as UTF-8 and must be valid+ * Many checks added for common mistakes+ * New --package-db= option for specific package databases+ * Many internal changes to support cabal-install+ * Stricter parsing for version strings, eg dissalows "1.05"+ * Improved user guide introduction+ * Programatica support removed+ * New options --program-prefix/suffix allows eg versioned programs+ * Support packages that use .hs-boot files+ * Fix sdist for Main modules that require preprocessing+ * New configure -O flag with optimisation level 0--2+ * Provide access to "x-" extension fields through the Cabal api+ * Added check for broken installed packages+ * Added warning about using inconsistent versions of dependencies+ * Strip binary executable files by default with an option to disable+ * New options to add site-specific include and library search paths+ * Lift the restriction that libraries must have exposed-modules+ * Many bugs fixed.+ * Many internal structural improvements and code cleanups++1.2.4.0 Duncan Coutts <duncan@haskell.org> June 2008+ * Released with GHC 6.8.3+ * Backported several fixes and minor improvements from Cabal-1.4+ * Use a default colour scheme for sources with hscolour >=1.9+ * Support --hyperlink-source for Haddock >= 2.0+ * Fix for running in a non-writable directory+ * Add OSX -framework arguments when linking executables+ * Updates to the user guide+ * Allow build-tools names to include + and _+ * Export autoconfUserHooks and simpleUserHooks+ * Export ccLdOptionsBuildInfo for Setup.hs scripts+ * Export unionBuildInfo and make BuildInfo an instance of Monoid+ * Fix to allow the 'main-is' module to use a pre-processor++1.2.3.0 Duncan Coutts <duncan@haskell.org> Nov 2007+ * Released with GHC 6.8.2+ * Includes full list of GHC language extensions+ * Fix infamous "dist/conftest.c" bug+ * Fix configure --interfacedir=+ * Find ld.exe on Windows correctly+ * Export PreProcessor constructor and mkSimplePreProcessor+ * Fix minor bug in unlit code+ * Fix some markup in the haddock docs++1.2.2.0 Duncan Coutts <duncan@haskell.org> Nov 2007+ * Released with GHC 6.8.1+ * Support haddock-2.0+ * Support building DSOs with GHC+ * Require reconfiguring if the .cabal file has changed+ * Fix os(windows) configuration test+ * Fix building documentation+ * Fix building packages on Solaris+ * Other minor bug fixes++1.2.1 Duncan Coutts <duncan@haskell.org> Oct 2007+ * To be included in GHC 6.8.1+ * New field "cpp-options" used when preprocessing Haskell modules+ * Fixes for hsc2hs when using ghc+ * C source code gets compiled with -O2 by default+ * OS aliases, to allow os(windows) rather than requiring os(mingw32)+ * Fix cleaning of 'stub' files+ * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs"+ * Build docs even when dependent packages docs are missing+ * Allow the --html-dir to be specified at configure time+ * Fix building with ghc-6.2+ * Other minor bug fixes and build fixes++1.2.0 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Sept 2007+ * To be included in GHC 6.8.x+ * New configurations feature+ * Can make haddock docs link to hilighted sources (with hscolour)+ * New flag to allow linking to haddock docs on the web+ * Supports pkg-config+ * New field "build-tools" for tool dependencies+ * Improved c2hs support+ * Preprocessor output no longer clutters source dirs+ * Seperate "includes" and "install-includes" fields+ * Makefile command to generate makefiles for building libs with GHC+ * New --docdir configure flag+ * Generic --with-prog --prog-args configure flags+ * Better default installation paths on Windows+ * Install paths can be specified relative to each other+ * License files now installed+ * Initial support for NHC (incomplete)+ * Consistent treatment of verbosity+ * Reduced verbosity of configure step by default+ * Improved helpfulness of output messages+ * Help output now clearer and fits in 80 columns+ * New setup register --gen-pkg-config flag for distros+ * Major internal refactoring, hooks api has changed+ * Dozens of bug fixes++1.1.6.2 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> May 2007+ * Released with GHC 6.6.1+ * Handle windows text file encoding for .cabal files+ * Fix compiling a executable for profiling that uses Template Haskell+ * Other minor bug fixes and user guide clarifications++1.1.6.1 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Oct 2006+ * fix unlit code+ * fix escaping in register.sh++1.1.6 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Oct 2006+ * Released with GHC 6.6+ * Added support for hoogle+ * Allow profiling and normal builds of libs to be chosen indepentantly+ * Default installation directories on Win32 changed+ * Register haddock docs with ghc-pkg+ * Get haddock to make hyperlinks to dependent package docs+ * Added BangPatterns language extension+ * Various bug fixes++1.1.4 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> May 2006+ * Released with GHC 6.4.2+ * Better support for packages that need to install header files+ * cabal-setup added, but not installed by default yet+ * Implemented "setup register --inplace"+ * Have packages exposed by default with ghc-6.2+ * It is no longer necessary to run 'configure' before 'clean' or 'sdist'+ * Added support for ghc's -split-objs+ * Initial support for JHC+ * Ignore extension fields in .cabal files (fields begining with "x-")+ * Some changes to command hooks API to improve consistency+ * Hugs support improvements+ * Added GeneralisedNewtypeDeriving language extension+ * Added cabal-version field+ * Support hidden modules with haddock+ * Internal code refactoring+ * More bug fixes++1.1.3 Isaac Jones <ijones@syntaxpolice.org> Sept 2005+ * WARNING: Interfaces not documented in the user's guide may+ change in future releases.+ * Move building of GHCi .o libs to the build phase rather than+ register phase. (from Duncan Coutts)+ * Use .tar.gz for source package extension+ * Uses GHC instead of cpphs if the latter is not available+ * Added experimental "command hooks" which completely override the+ default behavior of a command.+ * Some bugfixes++1.1.1 Isaac Jones <ijones@syntaxpolice.org> July 2005+ * WARNING: Interfaces not documented in the user's guide may+ change in future releases.+ * Handles recursive modules for GHC 6.2 and GHC 6.4.+ * Added "setup test" command (Used with UserHook)+ * implemented handling of _stub.{c,h,o} files+ * Added support for profiling+ * Changed install prefix of libraries (pref/pkgname-version+ to prefix/pkgname-version/compname-version)+ * Added pattern guards as a language extension+ * Moved some functionality to Language.Haskell.Extension+ * Register / unregister .bat files for windows+ * Exposed more of the API+ * Added support for the hide-all-packages flag in GHC > 6.4+ * Several bug fixes++1.0 Isaac Jones <ijones@syntaxpolice.org> March 11 2005+ * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18+ * Some sanity checking++0.5 Isaac Jones <ijones@syntaxpolice.org> Wed Feb 19 2005+ * WARNING: this is a pre-release and the interfaces are still+ likely to change until we reach a 1.0 release.+ * Hooks interfaces changed+ * Added preprocessors to user hooks+ * No more executable-modules or hidden-modules. Use+ "other-modules" instead.+ * Certain fields moved into BuildInfo, much refactoring+ * extra-libs -> extra-libraries+ * Added --gen-script to configure and unconfigure.+ * modules-ghc (etc) now ghc-modules (etc)+ * added new fields including "synopsis"+ * Lots of bug fixes+ * spaces can sometimes be used instead of commas+ * A user manual has appeared (Thanks, ross!)+ * for ghc 6.4, configures versionsed depends properly+ * more features to ./setup haddock++0.4 Isaac Jones <ijones@syntaxpolice.org> Sun Jan 16 2005++ * Much thanks to all the awesome fptools hackers who have been+ working hard to build the Haskell Cabal!++ * Interface Changes:++ ** WARNING: this is a pre-release and the interfaces are still+ likely to change until we reach a 1.0 release.++ ** Instead of Package.description, you should name your+ description files <something>.cabal. In particular, we suggest+ that you name it <packagename>.cabal, but this is not enforced+ (yet). Multiple .cabal files in the same directory is an error,+ at least for now.++ ** ./setup install --install-prefix is gone. Use ./setup copy+ --copy-prefix instead.++ ** The "Modules" field is gone. Use "hidden-modules",+ "exposed-modules", and "executable-modules".++ ** Build-depends is now a package-only field, and can't go into+ executable stanzas. Build-depends is a package-to-package+ relationship.++ ** Some new fields. Use the Source.++ * New Features++ ** Cabal is now included as a package in the CVS version of+ fptools. That means it'll be released as "-package Cabal" in+ future versions of the compilers, and if you are a bleeding-edge+ user, you can grab it from the CVS repository with the compilers.++ ** Hugs compatibility and NHC98 compatibility should both be+ improved.++ ** Hooks Interface / Autoconf compatibility: Most of the hooks+ interface is hidden for now, because it's not finalized. I have+ exposed only "defaultMainWithHooks" and "defaultUserHooks". This+ allows you to use a ./configure script to preprocess+ "foo.buildinfo", which gets merged with "foo.cabal". In future+ releases, we'll expose UserHooks, but we're definitely going to+ change the interface to those. The interface to the two functions+ I've exposed should stay the same, though.++ ** ./setup haddock is a baby feature which pre-processes the+ source code with hscpp and runs haddock on it. This is brand new+ and hardly tested, so you get to knock it around and see what you+ think.++ ** Some commands now actually implement verbosity.++ ** The preprocessors have been tested a bit more, and seem to work+ OK. Please give feedback if you use these.++0.3 Isaac Jones <ijones@syntaxpolice.org> Sun Jan 16 2005+ * Unstable snapshot release+ * From now on, stable releases are even.++0.2 Isaac Jones <ijones@syntaxpolice.org>++ * Adds more HUGS support and preprocessor support.
− mkGHCMakefile.sh
@@ -1,7 +0,0 @@-#!/bin/sh-file=Distribution/Simple/GHC/Makefile.hs-echo "-- DO NOT EDIT: change Makefile.in, and run ../../../mkGHCMakefile.sh" >$file-echo "module Distribution.Simple.GHC.Makefile where {" >>$file-echo "makefileTemplate :: String; makefileTemplate=unlines" >>$file-ghc -e "readFile \"Distribution/Simple/GHC/Makefile.in\" >>= print . lines" >>$file-echo "}" >>$file