diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -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 + Duncan Coutts 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 diff --git a/Distribution/Compat/Directory.hs b/Distribution/Compat/Directory.hs deleted file mode 100644 --- a/Distribution/Compat/Directory.hs +++ /dev/null @@ -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 - diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/Distribution/Compat/Exception.hs +++ /dev/null @@ -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 diff --git a/Distribution/Compat/Map.hs b/Distribution/Compat/Map.hs deleted file mode 100644 --- a/Distribution/Compat/Map.hs +++ /dev/null @@ -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 diff --git a/Distribution/Compat/RawSystem.hs b/Distribution/Compat/RawSystem.hs deleted file mode 100644 --- a/Distribution/Compat/RawSystem.hs +++ /dev/null @@ -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 diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs --- a/Distribution/Compat/ReadP.hs +++ b/Distribution/Compat/ReadP.hs @@ -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. diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs --- a/Distribution/Compat/TempFile.hs +++ b/Distribution/Compat/TempFile.hs @@ -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 diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -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 diff --git a/Distribution/Configuration.hs b/Distribution/Configuration.hs deleted file mode 100644 --- a/Distribution/Configuration.hs +++ /dev/null @@ -1,460 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Configuration --- Copyright : Thomas Schilling, 2007 --- --- Maintainer : Isaac Jones --- 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 diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs --- a/Distribution/GetOpt.hs +++ b/Distribution/GetOpt.hs @@ -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 diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -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 diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -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 diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -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"] diff --git a/Distribution/Package.hs b/Distribution/Package.hs --- a/Distribution/Package.hs +++ b/Distribution/Package.hs @@ -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 diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -1,1679 +1,1330 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Package description and parsing. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.PackageDescription ( - -- * Package descriptions - PackageDescription(..), - GenericPackageDescription(..), - 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 +-- 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." diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Check.hs @@ -0,0 +1,616 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008 +-- +-- Maintainer : Lennart Kolmodin +-- 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 "," diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Configuration.hs @@ -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 +-- 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." diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -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 diff --git a/Distribution/ReadE.hs b/Distribution/ReadE.hs new file mode 100644 --- /dev/null +++ b/Distribution/ReadE.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -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) diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -1,9 +1,8 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build -- Copyright : Isaac Jones 2003-2005 --- +-- -- Maintainer : Isaac Jones -- 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_.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 diff --git a/Distribution/Simple/BuildPaths.hs b/Distribution/Simple/BuildPaths.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/BuildPaths.hs @@ -0,0 +1,145 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- +-- Maintainer : Isaac Jones +-- 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- +-- 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" diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Command.hs @@ -0,0 +1,527 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : Duncan Coutts +-- 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] diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -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 diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -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 diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -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)" diff --git a/Distribution/Simple/GHC/PackageConfig.hs b/Distribution/Simple/GHC/PackageConfig.hs deleted file mode 100644 --- a/Distribution/Simple/GHC/PackageConfig.hs +++ /dev/null @@ -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))) diff --git a/Distribution/Simple/GHC/mkGHCMakefile.sh b/Distribution/Simple/GHC/mkGHCMakefile.sh new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/mkGHCMakefile.sh @@ -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 diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -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_ diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -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)] diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -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 diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -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 diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs --- a/Distribution/Simple/JHC.hs +++ b/Distribution/Simple/JHC.hs @@ -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) diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -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" #-} diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs --- a/Distribution/Simple/NHC.hs +++ b/Distribution/Simple/NHC.hs @@ -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) diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/PackageIndex.hs @@ -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 +-- 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 diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -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 ] diff --git a/Distribution/Simple/PreProcess/Unlit.hs b/Distribution/Simple/PreProcess/Unlit.hs --- a/Distribution/Simple/PreProcess/Unlit.hs +++ b/Distribution/Simple/PreProcess/Unlit.hs @@ -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" diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -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") { diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -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 diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -1,1031 +1,1434 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- 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 +-- 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? +-} diff --git a/Distribution/Simple/SetupWrapper.hs b/Distribution/Simple/SetupWrapper.hs --- a/Distribution/Simple/SetupWrapper.hs +++ b/Distribution/Simple/SetupWrapper.hs @@ -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] diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -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 diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/UserHooks.hs @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- 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 () diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -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 -- 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- --- 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 ." ++ 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 ." ++ 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 -- .cabal -findPackageDesc verbosity p - = do ls <- getDirectoryContents p - let descs = filter matchesDescFile ls - descriptionCheck verbosity descs +findPackageDesc :: FilePath -- ^Where to look + -> IO FilePath -- ^.cabal +findPackageDesc dir + = do files <- getDirectoryContents dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .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 .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 diff --git a/Distribution/System.hs b/Distribution/System.hs --- a/Distribution/System.hs +++ b/Distribution/System.hs @@ -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 diff --git a/Distribution/Text.hs b/Distribution/Text.hs new file mode 100644 --- /dev/null +++ b/Distribution/Text.hs @@ -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)) diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs --- a/Distribution/Verbosity.hs +++ b/Distribution/Verbosity.hs @@ -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 diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -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 diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -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 ] diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,256 @@ +-*-change-log-*- + +1.5.x (current development version) + +1.4.0.0 Duncan Coutts 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 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 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 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 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 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 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 Oct 2006 + * fix unlit code + * fix escaping in register.sh + +1.1.6 Duncan Coutts 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 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 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 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 March 11 2005 + * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 + * Some sanity checking + +0.5 Isaac Jones 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 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 .cabal. In particular, we suggest + that you name it .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 Sun Jan 16 2005 + * Unstable snapshot release + * From now on, stable releases are even. + +0.2 Isaac Jones + + * Adds more HUGS support and preprocessor support. diff --git a/mkGHCMakefile.sh b/mkGHCMakefile.sh deleted file mode 100644 --- a/mkGHCMakefile.sh +++ /dev/null @@ -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