diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,12 +1,10 @@ Name: Cabal -Version: 1.1.6 +Version: 1.2.1 Copyright: 2003-2006, Isaac Jones --- For ghc 6.2 you need to add 'unix' to Build-Depends: -Build-Depends: base License: BSD3 License-File: LICENSE Author: Isaac Jones -Maintainer: Isaac Jones +Maintainer: cabal-devel@haskell.org Homepage: http://www.haskell.org/cabal/ Synopsis: A framework for packaging Haskell software Description: @@ -18,40 +16,74 @@ for distributing, organizing, and cataloging Haskell libraries and tools. Category: Distribution -Exposed-Modules: +Build-Type: Custom +-- Even though we do use the default Setup.lhs it's vital to bootstraping +-- that we build Setup.lhs using our own local Cabal source code. + +Extra-Source-Files: + 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, filepath, pretty, directory, old-time, process, containers + else + Build-Depends: base, filepath + + if impl(ghc < 6.3) + Build-Depends: unix + + GHC-Options: -Wall + CPP-Options: "-DCABAL_VERSION=1,2,1" + nhc98-Options: -K4M + + Exposed-Modules: Distribution.Compiler, Distribution.Extension, + Distribution.Setup, Distribution.InstalledPackageInfo, Distribution.License, Distribution.Make, - Distribution.Program, Distribution.Package, Distribution.PackageDescription, + Distribution.Configuration, Distribution.ParseUtils, - Distribution.PreProcess, - Distribution.PreProcess.Unlit, - Distribution.Setup, Distribution.Simple, Distribution.Simple.Build, + Distribution.Simple.Compiler, Distribution.Simple.Configure, Distribution.Simple.GHC, - Distribution.Simple.GHCPackageConfig, + Distribution.Simple.GHC.Makefile, + Distribution.Simple.GHC.PackageConfig, + Distribution.Simple.Haddock, Distribution.Simple.Hugs, Distribution.Simple.Install, + Distribution.Simple.InstallDirs, Distribution.Simple.JHC, Distribution.Simple.LocalBuildInfo, Distribution.Simple.NHC, + Distribution.Simple.PreProcess, + Distribution.Simple.PreProcess.Unlit, + Distribution.Simple.Program, Distribution.Simple.Register, + Distribution.Simple.Setup, + Distribution.Simple.SetupWrapper, Distribution.Simple.SrcDist, Distribution.Simple.Utils, + Distribution.System, + Distribution.Verbosity, Distribution.Version, - Language.Haskell.Extension, - Distribution.Compat.FilePath -Other-Modules: + Distribution.Compat.ReadP, + Language.Haskell.Extension + + Other-Modules: Distribution.GetOpt, Distribution.Compat.Map, Distribution.Compat.Directory, Distribution.Compat.Exception, Distribution.Compat.RawSystem, - Distribution.Compat.ReadP -Extensions: CPP + Distribution.Compat.TempFile + + Extensions: CPP diff --git a/Distribution/Compat/Directory.hs b/Distribution/Compat/Directory.hs --- a/Distribution/Compat/Directory.hs +++ b/Distribution/Compat/Directory.hs @@ -2,7 +2,7 @@ -- #hide module Distribution.Compat.Directory ( module System.Directory, -#if __GLASGOW_HASKELL__ <= 602 +#if (__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ <= 602) findExecutable, copyFile, getHomeDirectory, createDirectoryIfMissing, removeDirectoryRecursive, #endif @@ -17,14 +17,14 @@ #endif #endif -#if !__GLASGOW_HASKELL__ || __GLASGOW_HASKELL__ > 602 +#if !(__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ <= 602) import System.Directory #else /* to end of file... */ import System.Environment ( getEnv ) -import Distribution.Compat.FilePath +import System.FilePath import System.IO import Foreign import System.Directory @@ -32,18 +32,19 @@ import Control.Monad (when, unless) #if !(mingw32_HOST_OS || mingw32_TARGET_OS) import System.Posix (getFileStatus,setFileMode,fileMode,accessTime, - setFileMode,modificationTime,setFileTimes) + modificationTime,setFileTimes) #endif +import Data.List ( scanl1 ) findExecutable :: String -> IO (Maybe FilePath) findExecutable binary = do path <- getEnv "PATH" - search (parseSearchPath path) + search (splitSearchPath path) where search :: [FilePath] -> IO (Maybe FilePath) search [] = return Nothing search (d:ds) = do - let path = d `joinFileName` binary `joinFileExt` exeSuffix + let path = d binary <.> exeSuffix b <- doesFileExist path if b then return (Just path) else search ds @@ -111,13 +112,17 @@ case (b,parents, file) of (_, _, "") -> return () (True, _, _) -> return () - (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file)) + (_, 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 . joinFileName startLoc) cont + mapM_ (rm . (startLoc )) cont removeDirectory startLoc where rm :: FilePath -> IO () diff --git a/Distribution/Compat/FilePath.hs b/Distribution/Compat/FilePath.hs deleted file mode 100644 --- a/Distribution/Compat/FilePath.hs +++ /dev/null @@ -1,459 +0,0 @@ -{-# OPTIONS -cpp #-} --- #hide -module Distribution.Compat.FilePath - ( -- * File path - FilePath - , splitFileName - , splitFileExt - , splitFilePath - , baseName - , dirName - , joinFileName - , joinFileExt - , joinPaths - , changeFileExt - , isRootedPath - , isAbsolutePath - , dropAbsolutePrefix - , breakFilePath - , dropPrefix - - , pathParents - , commonParent - - -- * Search path - , parseSearchPath - , mkSearchPath - - -- * Separators - , isPathSeparator - , pathSeparator - , searchPathSeparator - , platformPath - - -- * Filename extensions - , exeExtension - , objExtension - , dllExtension - ) where - -#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604 -#if __GLASGOW_HASKELL__ < 603 -#include "config.h" -#else -#include "ghcconfig.h" -#endif -#endif - -import Data.List(intersperse) - --------------------------------------------------------------- --- * FilePath --------------------------------------------------------------- - --- | Split the path into directory and file name --- --- Examples: --- --- \[Posix\] --- --- > splitFileName "/" == ("/", ".") --- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext") --- > splitFileName "bar.ext" == (".", "bar.ext") --- > splitFileName "/foo/." == ("/foo", ".") --- > splitFileName "/foo/.." == ("/foo", "..") --- --- \[Windows\] --- --- > splitFileName "\\" == ("\\", "") --- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext") --- > splitFileName "bar.ext" == (".", "bar.ext") --- > splitFileName "c:\\foo\\." == ("c:\\foo", ".") --- > splitFileName "c:\\foo\\.." == ("c:\\foo", "..") --- --- The first case in the Windows examples returns an empty file name. --- This is a special case because the \"\\\\\" path doesn\'t refer to --- an object (file or directory) which resides within a directory. -splitFileName :: FilePath -> (String, String) -#if mingw32_HOST_OS || mingw32_TARGET_OS -splitFileName p = (reverse (path2++drive), reverse fname) - where - (path,drive) = case p of - (c:':':p) -> (reverse p,[':',c]) - _ -> (reverse p,"") - (fname,path1) = break isPathSeparator path - path2 = case path1 of - [] -> "." - [_] -> path1 -- don't remove the trailing slash if - -- there is only one character - (c:path) | isPathSeparator c -> path - _ -> path1 -#else -splitFileName p = (reverse path1, reverse fname1) - where - (fname,path) = break isPathSeparator (reverse p) - path1 = case path of - "" -> "." - _ -> case dropWhile isPathSeparator path of - "" -> [pathSeparator] - p -> p - fname1 = case fname of - "" -> "." - _ -> fname -#endif - --- | Split the path into file name and extension. If the file doesn\'t have extension, --- the function will return empty string. The extension doesn\'t include a leading period. --- --- Examples: --- --- > splitFileExt "foo.ext" == ("foo", "ext") --- > splitFileExt "foo" == ("foo", "") --- > splitFileExt "." == (".", "") --- > splitFileExt ".." == ("..", "") --- > splitFileExt "foo.bar."== ("foo.bar.", "") --- > splitFileExt "foo.tar.gz" == ("foo.tar","gz") - -splitFileExt :: FilePath -> (String, String) -splitFileExt p = - case break (== '.') fname of - (suf@(_:_),_:pre) -> (reverse (pre++path), reverse suf) - _ -> (p, []) - where - (fname,path) = break isPathSeparator (reverse p) - --- | Split the path into directory, file name and extension. --- The function is an optimized version of the following equation: --- --- > splitFilePath path = (dir,name,ext) --- > where --- > (dir,basename) = splitFileName path --- > (name,ext) = splitFileExt basename -splitFilePath :: FilePath -> (String, String, String) -splitFilePath path = case break (== '.') (reverse basename) of - (name_r, "") -> (dir, reverse name_r, "") - (ext_r, _:name_r) -> (dir, reverse name_r, reverse ext_r) - where - (dir, basename) = splitFileName path - -baseName :: FilePath -> FilePath -baseName = snd . splitFileName -dirName :: FilePath -> FilePath -dirName = fst . splitFileName - - --- | The 'joinFileName' function is the opposite of 'splitFileName'. --- It joins directory and file names to form a complete file path. --- --- The general rule is: --- --- > dir `joinFileName` basename == path --- > where --- > (dir,basename) = splitFileName path --- --- There might be an exceptions to the rule but in any case the --- reconstructed path will refer to the same object (file or directory). --- An example exception is that on Windows some slashes might be converted --- to backslashes. -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (last dir) = dir++fname - | otherwise = dir++pathSeparator:fname - --- | The 'joinFileExt' function is the opposite of 'splitFileExt'. --- It joins a file name and an extension to form a complete file path. --- --- The general rule is: --- --- > filename `joinFileExt` ext == path --- > where --- > (filename,ext) = splitFileExt path -joinFileExt :: String -> String -> FilePath -joinFileExt path "" = path -joinFileExt path ext = path ++ '.':ext - --- | Given a directory path \"dir\" and a file\/directory path \"rel\", --- returns a merged path \"full\" with the property that --- (cd dir; do_something_with rel) is equivalent to --- (do_something_with full). If the \"rel\" path is an absolute path --- then the returned path is equal to \"rel\" -joinPaths :: FilePath -> FilePath -> FilePath -joinPaths path1 path2 - | isRootedPath path2 = path2 - | otherwise = -#if mingw32_HOST_OS || mingw32_TARGET_OS - case path2 of - d:':':path2' | take 2 path1 == [d,':'] -> path1 `joinFileName` path2' - | otherwise -> path2 - _ -> path1 `joinFileName` path2 -#else - path1 `joinFileName` path2 -#endif - --- | Changes the extension of a file path. -changeFileExt :: FilePath -- ^ The path information to modify. - -> String -- ^ The new extension (without a leading period). - -- Specify an empty string to remove an existing - -- extension from path. - -> FilePath -- ^ A string containing the modified path information. -changeFileExt path ext = joinFileExt name ext - where - (name,_) = splitFileExt path - --- | On Unix and Macintosh the 'isRootedPath' function is a synonym to 'isAbsolutePath'. --- The difference is important only on Windows. The rooted path must start from the root --- directory but may not include the drive letter while the absolute path always includes --- the drive letter and the full file path. -isRootedPath :: FilePath -> Bool -isRootedPath (c:_) | isPathSeparator c = True -#if mingw32_HOST_OS || mingw32_TARGET_OS -isRootedPath (_:':':c:_) | isPathSeparator c = True -- path with drive letter -#endif -isRootedPath _ = False - --- | Returns 'True' if this path\'s meaning is independent of any OS --- \"working directory\", or 'False' if it isn\'t. -isAbsolutePath :: FilePath -> Bool -#if mingw32_HOST_OS || mingw32_TARGET_OS -isAbsolutePath (_:':':c:_) | isPathSeparator c = True -#else -isAbsolutePath (c:_) | isPathSeparator c = True -#endif -isAbsolutePath _ = False - --- | If the function is applied to an absolute path then it returns a local path droping --- the absolute prefix in the path. Under Windows the prefix is \"\\\", \"c:\" or \"c:\\\". Under --- Unix the prefix is always \"\/\". -dropAbsolutePrefix :: FilePath -> FilePath -dropAbsolutePrefix (c:cs) | isPathSeparator c = cs -#if mingw32_HOST_OS || mingw32_TARGET_OS -dropAbsolutePrefix (_:':':c:cs) | isPathSeparator c = cs -- path with drive letter -dropAbsolutePrefix (_:':':cs) = cs -#endif -dropAbsolutePrefix cs = cs - --- | Split the path into a list of strings constituting the filepath --- --- > breakFilePath "/usr/bin/ls" == ["/","usr","bin","ls"] -breakFilePath :: FilePath -> [String] -breakFilePath = worker [] - where worker ac path - | less == path = less:ac - | otherwise = worker (current:ac) less - where (less,current) = splitFileName path - --- | Drops a specified prefix from a filepath. --- --- > dropPrefix "." "Src/Test.hs" == "Src/Test.hs" --- > dropPrefix "Src" "Src/Test.hs" == "Test.hs" -dropPrefix :: FilePath -> FilePath -> FilePath -dropPrefix prefix path - = worker (breakFilePath prefix) (breakFilePath path) - where worker (x:xs) (y:ys) - | x == y = worker xs ys - worker _ ys = foldr1 joinPaths ys --- | Gets this path and all its parents. --- The function is useful in case if you want to create --- some file but you aren\'t sure whether all directories --- in the path exist or if you want to search upward for some file. --- --- Some examples: --- --- \[Posix\] --- --- > pathParents "/" == ["/"] --- > pathParents "/dir1" == ["/", "/dir1"] --- > pathParents "/dir1/dir2" == ["/", "/dir1", "/dir1/dir2"] --- > pathParents "dir1" == [".", "dir1"] --- > pathParents "dir1/dir2" == [".", "dir1", "dir1/dir2"] --- --- \[Windows\] --- --- > pathParents "c:" == ["c:."] --- > pathParents "c:\\" == ["c:\\"] --- > pathParents "c:\\dir1" == ["c:\\", "c:\\dir1"] --- > pathParents "c:\\dir1\\dir2" == ["c:\\", "c:\\dir1", "c:\\dir1\\dir2"] --- > pathParents "c:dir1" == ["c:.","c:dir1"] --- > pathParents "dir1\\dir2" == [".", "dir1", "dir1\\dir2"] --- --- Note that if the file is relative then the current directory (\".\") --- will be explicitly listed. -pathParents :: FilePath -> [FilePath] -pathParents p = - root'' : map ((++) root') (dropEmptyPath $ inits path') - where -#if mingw32_HOST_OS || mingw32_TARGET_OS - (root,path) = case break (== ':') p of - (path, "") -> ("",path) - (root,_:path) -> (root++":",path) -#else - (root,path) = ("",p) -#endif - (root',root'',path') = case path of - (c:path) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path) - _ -> (root ,root++"." ,path) - - dropEmptyPath ("":paths) = paths - dropEmptyPath paths = paths - - inits :: String -> [String] - inits [] = [""] - inits cs = - case pre of - "." -> inits suf - ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf) - _ -> "" : map (joinFileName pre) (inits suf) - where - (pre,suf) = case break isPathSeparator cs of - (pre,"") -> (pre, "") - (pre,_:suf) -> (pre,suf) - --- | Given a list of file paths, returns the longest common parent. -commonParent :: [FilePath] -> Maybe FilePath -commonParent [] = Nothing -commonParent paths@(p:ps) = - case common Nothing "" p ps of -#if mingw32_HOST_OS || mingw32_TARGET_OS - Nothing | all (not . isAbsolutePath) paths -> - let - getDrive (d:':':_) ds - | not (d `elem` ds) = d:ds - getDrive _ ds = ds - in - case foldr getDrive [] paths of - [] -> Just "." - [d] -> Just [d,':'] - _ -> Nothing -#else - Nothing | all (not . isAbsolutePath) paths -> Just "." -#endif - mb_path -> mb_path - where - common i acc [] ps = checkSep i acc ps - common i acc (c:cs) ps - | isPathSeparator c = removeSep i acc cs [] ps - | otherwise = removeChar i acc c cs [] ps - - checkSep i acc [] = Just (reverse acc) - checkSep i acc ([]:ps) = Just (reverse acc) - checkSep i acc ((c1:p):ps) - | isPathSeparator c1 = checkSep i acc ps - checkSep i acc ps = i - - removeSep i acc cs pacc [] = - common (Just (reverse (pathSeparator:acc))) (pathSeparator:acc) cs pacc - removeSep i acc cs pacc ([] :ps) = Just (reverse acc) - removeSep i acc cs pacc ((c1:p):ps) - | isPathSeparator c1 = removeSep i acc cs (p:pacc) ps - removeSep i acc cs pacc ps = i - - removeChar i acc c cs pacc [] = common i (c:acc) cs pacc - removeChar i acc c cs pacc ([] :ps) = i - removeChar i acc c cs pacc ((c1:p):ps) - | c == c1 = removeChar i acc c cs (p:pacc) ps - removeChar i acc c cs pacc ps = i - --------------------------------------------------------------- --- * Search path --------------------------------------------------------------- - --- | The function splits the given string to substrings --- using the 'searchPathSeparator'. -parseSearchPath :: String -> [FilePath] -parseSearchPath path = split path - where - split :: String -> [String] - split s = - case rest' of - [] -> [chunk] - _:rest -> chunk : split rest - where - chunk = - case chunk' of -#ifdef mingw32_HOST_OS - ('\"':xs@(_:_)) | last xs == '\"' -> init xs -#endif - _ -> chunk' - - (chunk', rest') = break (==searchPathSeparator) s - --- | The function concatenates the given paths to form a --- single string where the paths are separated with 'searchPathSeparator'. -mkSearchPath :: [FilePath] -> String -mkSearchPath paths = concat (intersperse [searchPathSeparator] paths) - - --------------------------------------------------------------- --- * Separators --------------------------------------------------------------- - --- | Checks whether the character is a valid path separator for the host --- platform. The valid character is a 'pathSeparator' but since the Windows --- operating system also accepts a slash (\"\/\") since DOS 2, the function --- checks for it on this platform, too. -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#if mingw32_HOST_OS || mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif - --- | Provides a platform-specific character used to separate directory levels in --- a path string that reflects a hierarchical file system organization. The --- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash --- (@\"\\\"@) on the Windows operating system. -pathSeparator :: Char -#if mingw32_HOST_OS || mingw32_TARGET_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - --- | A platform-specific character used to separate search path strings in --- environment variables. The separator is a colon (\":\") on Unix and Macintosh, --- and a semicolon (\";\") on the Windows operating system. -searchPathSeparator :: Char -#if mingw32_HOST_OS || mingw32_TARGET_OS -searchPathSeparator = ';' -#else -searchPathSeparator = ':' -#endif - --- |Convert Unix-style path separators to the path separators for this platform. -platformPath :: FilePath -> FilePath -#if mingw32_HOST_OS || mingw32_TARGET_OS -platformPath = map slash - where slash '/' = '\\' - slash c = c -#else -platformPath = id -#endif - --- 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 -#if mingw32_HOST_OS || mingw32_TARGET_OS -exeExtension = "exe" -#else -exeExtension = "" -#endif - --- 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 -#if mingw32_HOST_OS || mingw32_TARGET_OS -dllExtension = "dll" -#else -dllExtension = "so" -#endif diff --git a/Distribution/Compat/Map.hs b/Distribution/Compat/Map.hs --- a/Distribution/Compat/Map.hs +++ b/Distribution/Compat/Map.hs @@ -5,7 +5,9 @@ member, lookup, findWithDefault, empty, insert, insertWith, + update, union, unionWith, unions, + difference, elems, keys, fromList, fromListWith, toAscList @@ -38,9 +40,22 @@ 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 @@ -49,6 +64,10 @@ 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 diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/TempFile.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -cpp #-} +-- #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 ( (), (<.>) ) + +#if (__GLASGOW_HASKELL__ || __HUGS__) +import System.Posix.Internals (c_getpid) +#else +import System.Posix.Types (CPid(..)) +#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. + +-- 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 + 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 + 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 + = do x <- getProcessID + findTempName x + where + findTempName x + = do let filename = ("tmp" ++ show x) <.> extn + path = tmp_dir filename + b <- doesFileExist path + if b then findTempName (x+1) + else action path `finally` try (removeFile path) + diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -8,7 +8,7 @@ -- Stability : alpha -- Portability : portable -- --- Haskell implementations. +-- Haskell compiler flavors {- All rights reserved. @@ -40,171 +40,22 @@ (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 ( - -- * Haskell implementations - CompilerFlavor(..), Compiler(..), showCompilerId, - compilerBinaryName, - -- * Support for language extensions - Opt, - extensionsToFlags, - extensionsToGHCFlag, extensionsToHugsFlag, - extensionsToNHCFlag, extensionsToJHCFlag, -#ifdef DEBUG - hunitTests -#endif - ) where - -import Distribution.Version (Version(..), showVersion) -import Language.Haskell.Extension (Extension(..)) - -import Data.List (nub) - -#ifdef DEBUG -import HUnit (Test) -#endif - --- ------------------------------------------------------------ --- * Command Line Types and Exports --- ------------------------------------------------------------ +module Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor) where data CompilerFlavor = GHC | NHC | Hugs | HBC | Helium | JHC | OtherCompiler String - deriving (Show, Read, Eq) - -data Compiler = Compiler {compilerFlavor:: CompilerFlavor, - compilerVersion :: Version, - compilerPath :: FilePath, - compilerPkgTool :: FilePath} - deriving (Show, Read, Eq) - -showCompilerId :: Compiler -> String -showCompilerId (Compiler f (Version [] _) _ _) = compilerBinaryName f -showCompilerId (Compiler f v _ _) = compilerBinaryName f ++ '-': showVersion v - -compilerBinaryName :: CompilerFlavor -> String -compilerBinaryName GHC = "ghc" -compilerBinaryName NHC = "hmake" -- FIX: uses hmake for now -compilerBinaryName Hugs = "ffihugs" -compilerBinaryName JHC = "jhc" -compilerBinaryName cmp = error $ "Unsupported compiler: " ++ (show cmp) - --- ------------------------------------------------------------ --- * Extensions --- ------------------------------------------------------------ - --- |For the given compiler, return the unsupported extensions, and the --- flags for the supported extensions. -extensionsToFlags :: CompilerFlavor -> [ Extension ] -> ([Extension], [Opt]) -extensionsToFlags GHC exts = extensionsToGHCFlag exts -extensionsToFlags Hugs exts = extensionsToHugsFlag exts -extensionsToFlags NHC exts = extensionsToNHCFlag exts -extensionsToFlags JHC exts = extensionsToJHCFlag exts -extensionsToFlags _ exts = (exts, []) - --- |GHC: Return the unsupported extensions, and the flags for the supported extensions -extensionsToGHCFlag :: [ Extension ] -> ([Extension], [Opt]) -extensionsToGHCFlag l - = splitEither $ nub $ map extensionToGHCFlag l - where - extensionToGHCFlag :: Extension -> Either Extension String - extensionToGHCFlag OverlappingInstances = Right "-fallow-overlapping-instances" - extensionToGHCFlag TypeSynonymInstances = Right "-fglasgow-exts" - extensionToGHCFlag TemplateHaskell = Right "-fth" - extensionToGHCFlag ForeignFunctionInterface = Right "-fffi" - extensionToGHCFlag NoMonomorphismRestriction = Right "-fno-monomorphism-restriction" - extensionToGHCFlag UndecidableInstances = Right "-fallow-undecidable-instances" - extensionToGHCFlag IncoherentInstances = Right "-fallow-incoherent-instances" - extensionToGHCFlag InlinePhase = Right "-finline-phase" - extensionToGHCFlag ContextStack = Right "-fcontext-stack" - extensionToGHCFlag Arrows = Right "-farrows" - extensionToGHCFlag Generics = Right "-fgenerics" - extensionToGHCFlag NoImplicitPrelude = Right "-fno-implicit-prelude" - extensionToGHCFlag ImplicitParams = Right "-fimplicit-params" - extensionToGHCFlag CPP = Right "-cpp" - - extensionToGHCFlag BangPatterns = Right "-fbang-patterns" - extensionToGHCFlag RecursiveDo = Right "-fglasgow-exts" - extensionToGHCFlag ParallelListComp = Right "-fglasgow-exts" - extensionToGHCFlag MultiParamTypeClasses = Right "-fglasgow-exts" - extensionToGHCFlag FunctionalDependencies = Right "-fglasgow-exts" - extensionToGHCFlag Rank2Types = Right "-fglasgow-exts" - extensionToGHCFlag RankNTypes = Right "-fglasgow-exts" - extensionToGHCFlag PolymorphicComponents = Right "-fglasgow-exts" - extensionToGHCFlag ExistentialQuantification = Right "-fglasgow-exts" - extensionToGHCFlag ScopedTypeVariables = Right "-fglasgow-exts" - extensionToGHCFlag FlexibleContexts = Right "-fglasgow-exts" - extensionToGHCFlag FlexibleInstances = Right "-fglasgow-exts" - extensionToGHCFlag EmptyDataDecls = Right "-fglasgow-exts" - extensionToGHCFlag PatternGuards = Right "-fglasgow-exts" - extensionToGHCFlag GeneralizedNewtypeDeriving = Right "-fglasgow-exts" - - extensionToGHCFlag e@ExtensibleRecords = Left e - extensionToGHCFlag e@RestrictedTypeSynonyms = Left e - extensionToGHCFlag e@HereDocuments = Left e - extensionToGHCFlag e@NamedFieldPuns = Left e - --- |NHC: Return the unsupported extensions, and the flags for the supported extensions -extensionsToNHCFlag :: [ Extension ] -> ([Extension], [Opt]) -extensionsToNHCFlag l - = splitEither $ nub $ map extensionToNHCFlag l - where - -- NHC doesn't enforce the monomorphism restriction at all. - extensionToNHCFlag NoMonomorphismRestriction = Right "" - extensionToNHCFlag ForeignFunctionInterface = Right "" - extensionToNHCFlag ExistentialQuantification = Right "" - extensionToNHCFlag EmptyDataDecls = Right "" - extensionToNHCFlag NamedFieldPuns = Right "-puns" - extensionToNHCFlag CPP = Right "-cpp" - extensionToNHCFlag e = Left e - --- |JHC: Return the unsupported extensions, and the flags for the supported extensions -extensionsToJHCFlag :: [ Extension ] -> ([Extension], [Opt]) -extensionsToJHCFlag l = (es, filter (not . null) rs) - where - (es,rs) = splitEither $ nub $ map extensionToJHCFlag l - extensionToJHCFlag TypeSynonymInstances = Right "" - extensionToJHCFlag ForeignFunctionInterface = Right "" - extensionToJHCFlag NoImplicitPrelude = Right "--noprelude" - extensionToJHCFlag CPP = Right "-fcpp" - extensionToJHCFlag e = Left e - --- |Hugs: Return the unsupported extensions, and the flags for the supported extensions -extensionsToHugsFlag :: [ Extension ] -> ([Extension], [Opt]) -extensionsToHugsFlag l - = splitEither $ nub $ map extensionToHugsFlag l - where - extensionToHugsFlag OverlappingInstances = Right "+o" - extensionToHugsFlag IncoherentInstances = Right "+oO" - extensionToHugsFlag HereDocuments = Right "+H" - extensionToHugsFlag TypeSynonymInstances = Right "-98" - extensionToHugsFlag RecursiveDo = Right "-98" - extensionToHugsFlag ParallelListComp = Right "-98" - extensionToHugsFlag MultiParamTypeClasses = Right "-98" - extensionToHugsFlag FunctionalDependencies = Right "-98" - extensionToHugsFlag Rank2Types = Right "-98" - extensionToHugsFlag PolymorphicComponents = Right "-98" - extensionToHugsFlag ExistentialQuantification = Right "-98" - extensionToHugsFlag ScopedTypeVariables = Right "-98" - extensionToHugsFlag ImplicitParams = Right "-98" - extensionToHugsFlag ExtensibleRecords = Right "-98" - extensionToHugsFlag RestrictedTypeSynonyms = Right "-98" - extensionToHugsFlag FlexibleContexts = Right "-98" - extensionToHugsFlag FlexibleInstances = Right "-98" - extensionToHugsFlag ForeignFunctionInterface = Right "" - extensionToHugsFlag EmptyDataDecls = Right "" - extensionToHugsFlag CPP = Right "" - extensionToHugsFlag e = Left e - -splitEither :: [Either a b] -> ([a], [b]) -splitEither l = ([a | Left a <- l], [b | Right b <- l]) - -type Opt = String - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ + deriving (Show, Read, Eq, Ord) -#ifdef DEBUG -hunitTests :: [Test] -hunitTests = [] +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 diff --git a/Distribution/Configuration.hs b/Distribution/Configuration.hs new file mode 100644 --- /dev/null +++ b/Distribution/Configuration.hs @@ -0,0 +1,460 @@ +{-# 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/Extension.hs b/Distribution/Extension.hs --- a/Distribution/Extension.hs +++ b/Distribution/Extension.hs @@ -41,11 +41,7 @@ module Distribution.Extension {-# DEPRECATED "Use modules Language.Haskell.Extension and Distribution.Compiler instead" #-} - (Extension(..), Opt, - extensionsToNHCFlag, extensionsToGHCFlag, - extensionsToJHCFlag, extensionsToHugsFlag + (Extension(..) ) where -import Distribution.Compiler (Opt, extensionsToNHCFlag, extensionsToGHCFlag, - extensionsToJHCFlag, extensionsToHugsFlag) import Language.Haskell.Extension (Extension(..)) diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs --- a/Distribution/GetOpt.hs +++ b/Distribution/GetOpt.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.GetOpt @@ -52,14 +51,7 @@ -- $example ) where -#if __GLASGOW_HASKELL__ >= 604 || !__GLASGOW_HASKELL__ - -import System.Console.GetOpt - -#else --- to end of file: - -import Data.List ( isPrefixOf ) +import Data.List ( isPrefixOf, intersperse ) -- |What to do with options following non-options data ArgOrder a @@ -107,22 +99,26 @@ -> [OptDescr a] -- option descriptors -> String -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr - table = zipWith3 paste (sameLen ss) (sameLen ls) ds - paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z - sameLen xs = flushLeft ((maximum . map length) xs) xs - flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] + where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos) + ,sepBy ", " (map (fmtLong ad) los) + ,d) + | Option sos los ad d <- optDescr ] + ssWidth = (maximum . map length) ss + lsWidth = (maximum . map length) ls + dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) + table = [ " " ++ padTo ssWidth so' ++ + " " ++ padTo lsWidth lo' ++ + " " ++ d' + | (so,lo,d) <- zip3 ss ls ds + , (so',lo',d') <- fmtOpt dsWidth so lo d ] + padTo n x = take n (x ++ repeat ' ') + sepBy s = concat . intersperse s -fmtOpt :: OptDescr a -> [(String,String,String)] -fmtOpt (Option sos los ad descr) = - case lines descr of - [] -> [(sosFmt,losFmt,"")] - (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] - where sepBy _ [] = "" - sepBy _ [x] = x - sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs - sosFmt = sepBy ',' (map (fmtShort ad) sos) - losFmt = sepBy ',' (map (fmtLong ad) los) +fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] +fmtOpt descrWidth so lo descr = + case wrapText descrWidth descr of + [] -> [(so,lo,"")] + (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _ ) so = "-" ++ [so] @@ -134,6 +130,21 @@ fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + {-| Process the command-line, and return the list of values that matched (and those that didn\'t). The arguments are: @@ -284,8 +295,6 @@ -- -n USER --name=USER only dump USER's files ----------------------------------------------------------------------------------------- -} - -#endif {- $example diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -47,7 +47,7 @@ module Distribution.InstalledPackageInfo ( InstalledPackageInfo(..), - ParseResult(..), + ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, parseInstalledPackageInfo, showInstalledPackageInfo, @@ -55,13 +55,12 @@ ) where import Distribution.ParseUtils ( - StanzaField(..), singleStanza, ParseResult(..), LineNo, - simpleField, listField, parseLicenseQ, + FieldDescr(..), readFields, ParseResult(..), PError(..), PWarning, + Field(F), simpleField, listField, parseLicenseQ, parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ, showFilePath, showToken, parseReadS, parseOptVersion, parseQuoted, showFreeText) import Distribution.License ( License(..) ) -import Distribution.Compiler ( Opt ) import Distribution.Package ( PackageIdentifier(..), showPackageId, parsePackageId ) import Distribution.Version ( Version(..), showVersion ) @@ -98,9 +97,9 @@ includeDirs :: [FilePath], includes :: [String], depends :: [PackageIdentifier], - hugsOptions :: [Opt], - ccOptions :: [Opt], - ldOptions :: [Opt], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], frameworkDirs :: [FilePath], frameworks :: [String], haddockInterfaces :: [FilePath], @@ -149,48 +148,51 @@ parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo parseInstalledPackageInfo inp = do - stLines <- singleStanza inp + stLines <- readFields inp -- not interested in stanzas, so just allow blank lines in -- the package info. - foldM (parseBasicStanza fields) emptyInstalledPackageInfo stLines + foldM (parseBasicStanza all_fields) emptyInstalledPackageInfo stLines -parseBasicStanza :: [StanzaField a] +parseBasicStanza :: [FieldDescr a] -> a - -> (LineNo, String, String) + -> Field -> ParseResult a -parseBasicStanza ((StanzaField name _ set):fields) pkg (lineNo, f, val) +parseBasicStanza ((FieldDescr name _ set):fields) pkg (F lineNo f val) | name == f = set lineNo val pkg - | otherwise = parseBasicStanza fields pkg (lineNo, f, val) -parseBasicStanza [] pkg (_, _, _) = return pkg + | otherwise = parseBasicStanza fields pkg (F lineNo f val) +parseBasicStanza [] pkg _ = return pkg +parseBasicStanza _ _ _ = + error "parseBasicStanza must be called with a simple field." -- ----------------------------------------------------------------------------- -- Pretty-printing showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo pkg = render (ppFields fields) +showInstalledPackageInfo pkg = render (ppFields all_fields) where ppFields [] = empty - ppFields ((StanzaField name get' _):flds) = + ppFields ((FieldDescr name get' _):flds) = pprField name (get' pkg) $$ ppFields flds showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showInstalledPackageInfoField field - = case [ (f,get') | (StanzaField f get' _) <- fields, f == field ] of + = 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 -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing -fields :: [StanzaField InstalledPackageInfo] -fields = basicStanzaFields ++ installedStanzaFields +all_fields :: [FieldDescr InstalledPackageInfo] +all_fields = basicFieldDescrs ++ installedFieldDescrs -basicStanzaFields :: [StanzaField InstalledPackageInfo] -basicStanzaFields = +basicFieldDescrs :: [FieldDescr InstalledPackageInfo] +basicFieldDescrs = [ simpleField "name" text parsePackageNameQ (pkgName . package) (\name pkg -> pkg{package=(package pkg){pkgName=name}}) @@ -226,8 +228,8 @@ author (\val pkg -> pkg{author=val}) ] -installedStanzaFields :: [StanzaField InstalledPackageInfo] -installedStanzaFields = [ +installedFieldDescrs :: [FieldDescr InstalledPackageInfo] +installedFieldDescrs = [ simpleField "exposed" (text.show) parseReadS exposed (\val pkg -> pkg{exposed=val}) @@ -284,4 +286,6 @@ haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) ] +parsePackageId' :: ReadP [PackageIdentifier] PackageIdentifier parsePackageId' = parseQuoted parsePackageId <++ parsePackageId + diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -50,12 +50,13 @@ ) where -- |This datatype indicates the license under which your package is --- released. It is also wise to add your license to each source file. --- The 'AllRightsReserved' constructor is not actually a license, but --- states that you are not giving anyone else a license to use or --- distribute your work. The comments below are general guidelines. --- Please read the licenses themselves and consult a lawyer if you are --- unsure of your rights to release the software. +-- released. It is also wise to add your license to each source file +-- using the license-file field. The 'AllRightsReserved' constructor +-- is not actually a license, but states that you are not giving +-- anyone else a license to use or distribute your work. The comments +-- 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 = GPL -- ^GNU Public License. Source code must accompany alterations. | LGPL -- ^Lesser GPL, Less restrictive than GPL, useful for libraries. diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -7,10 +7,46 @@ -- Stability : alpha -- Portability : portable -- --- Explanation: Uses the parsed command-line from Distribution.Setup --- in order to build haskell tools using a backend build system based --- on Make. +-- Uses the parsed command-line from Distribution.Setup in order to build +-- Haskell tools using a backend build system based on make. Obviously we +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. +-- +-- [ProgramaticaCmd] We assume there is a @programatica@ target. + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + {- All rights reserved. Redistribution and use in source and binary forms, with or without @@ -44,89 +80,61 @@ module Distribution.Make ( module Distribution.Package, License(..), Version(..), - defaultMain, defaultMainNoRead + defaultMain, defaultMainArgs, defaultMainNoRead ) where -- local import Distribution.Package --must not specify imports, since we're exporting moule. -import Distribution.Program(defaultProgramConfiguration) +import Distribution.Simple.Program(defaultProgramConfiguration) import Distribution.PackageDescription -import Distribution.Setup --(parseArgs, Action(..), optionHelpString) +import Distribution.Simple.Setup -import Distribution.Simple.Utils (die, maybeExit, defaultPackageDesc) +import Distribution.Simple.Utils (die, maybeExit) import Distribution.License (License(..)) import Distribution.Version (Version(..)) +import Distribution.Verbosity import System.Environment(getArgs) import Data.List ( intersperse ) import System.Cmd import System.Exit -{- -Basic assumptions ------------------ -Obviously we assume that there is a configure script, and that after the -ConfigCmd has been run, there is a Makefile. - -ConfigCmd: We assume the configure script accepts: - --with-hc - --with-hc-pkg - --prefix - --bindir - --libdir - --libexecdir - --datadir - -BuildCmd: We assume the default Makefile target will build everything - -InstallCmd: We assume there is an install target - Note that we assume that this does *not* register the package! - -CopyCmd: We assume there is a copy target, and a variable $(destdir) - The 'copy' target should probably just invoke make install recursively, eg. - copy : - $(MAKE) install prefix=$(destdir)/$(prefix) \ - bindir=$(destdir)/$(bindir) \ - ... - The reason we can't invoke make install directly here is that we don't - know the value of $(prefix). - -SDistCmd: We assume there is an dist target - -RegisterCmd: We assume there is a register target and a variable $(user) - -UnregisterCmd: We assume there is an unregister target - -HaddockCmd: We assume there is a "docs" or "doc" target - -ProgramaticaCmd: We assume there is a "programatica" target --} - exec :: String -> IO ExitCode exec cmd = (putStrLn $ "-=-= Cabal executing: " ++ cmd ++ "=-=-") >> system cmd defaultMain :: IO () -defaultMain = defaultPackageDesc >>= readPackageDescription >>= defaultMainNoRead +defaultMain = getArgs >>= defaultMainArgs +defaultMainArgs :: [String] -> IO () +defaultMainArgs args = + defaultMainHelper args $ \ _verbosity -> + error "Package Descripion was promised not be used here" + --defaultPackageDesc verbosity >>= + -- readPackageDescription verbosity + defaultMainNoRead :: PackageDescription -> IO () -defaultMainNoRead pkg_descr - = do args <- getArgs - (action, args) <- parseGlobalArgs defaultProgramConfiguration args +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 - (flags, _, args) <- parseConfigureArgs defaultProgramConfiguration flags args [] + (configFlags, _, extraArgs) <- parseConfigureArgs defaultProgramConfiguration flags args [] retVal <- exec $ unwords $ - "./configure" : configureArgs flags ++ args + "./configure" : configureArgs configFlags ++ extraArgs if (retVal == ExitSuccess) then putStrLn "Configure Succeeded." else putStrLn "Configure failed." exitWith retVal CopyCmd copydest0 -> do - ((CopyFlags copydest _), _, args) <- parseCopyArgs (CopyFlags copydest0 0) args [] - no_extra_flags args + ((CopyFlags copydest _), _, extraArgs) <- parseCopyArgs (CopyFlags copydest0 normal) args [] + no_extra_flags extraArgs let cmd = case copydest of NoCopyDest -> "install" CopyTo path -> "copy destdir=" ++ path @@ -135,8 +143,8 @@ maybeExit $ system $ ("make " ++ cmd) InstallCmd -> do - ((InstallFlags _ _), _, args) <- parseInstallArgs emptyInstallFlags args [] - no_extra_flags args + ((InstallFlags _ _), _, extraArgs) <- parseInstallArgs emptyInstallFlags args [] + no_extra_flags extraArgs maybeExit $ system $ "make install" retVal <- exec "make register" if (retVal == ExitSuccess) @@ -145,8 +153,8 @@ exitWith retVal HaddockCmd -> do - (_, _, args) <- parseHaddockArgs emptyHaddockFlags args [] - no_extra_flags args + (_, _, extraArgs) <- parseHaddockArgs emptyHaddockFlags args [] + no_extra_flags extraArgs retVal <- exec "make docs" case retVal of ExitSuccess -> do putStrLn "Haddock Succeeded" @@ -158,10 +166,16 @@ _ -> do putStrLn "Haddock Failed." exitWith retVal' - BuildCmd -> basicCommand "Build" "make" (parseBuildArgs args []) + BuildCmd -> basicCommand "Build" "make" + (parseBuildArgs defaultProgramConfiguration + (emptyBuildFlags defaultProgramConfiguration) + args []) - CleanCmd -> basicCommand "Clean" "make clean" (parseCleanArgs args []) + MakefileCmd -> exitWith ExitSuccess -- presumably nothing to do + CleanCmd -> basicCommand "Clean" "make clean" + (parseCleanArgs emptyCleanFlags args []) + SDistCmd -> basicCommand "SDist" "make dist" (parseSDistArgs args []) RegisterCmd -> basicCommand "Register" "make register" @@ -173,6 +187,9 @@ (parseProgramaticaArgs args []) HelpCmd -> exitWith ExitSuccess -- this is handled elsewhere + + _ -> do putStrLn "Command not implemented for makefiles." + exitWith (ExitFailure 1) -- |convinience function for repetitions above basicCommand :: String -- ^Command name diff --git a/Distribution/Package.hs b/Distribution/Package.hs --- a/Distribution/Package.hs +++ b/Distribution/Package.hs @@ -7,7 +7,7 @@ -- Stability : alpha -- Portability : portable -- --- Packages. +-- Packages are fundamentally just a name and a version. {- All rights reserved. @@ -49,13 +49,15 @@ import Data.Char ( isDigit, isAlphaNum ) import Data.List ( intersperse ) +-- | The name and version of a package. data PackageIdentifier = PackageIdentifier { - pkgName :: String, - pkgVersion :: Version + pkgName :: String, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 } 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 = @@ -70,6 +72,7 @@ -- 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 diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -43,854 +43,1633 @@ module Distribution.PackageDescription ( -- * Package descriptions PackageDescription(..), - emptyPackageDescription, - readPackageDescription, - parseDescription, - StanzaField(..), - LineNo, - basicStanzaFields, - writePackageDescription, - showPackageDescription, - sanityCheckPackage, errorOut, - setupMessage, - Library(..), - withLib, - hasLibs, - libModules, - Executable(..), - withExe, - exeModules, - -- * Build information - BuildInfo(..), - emptyBuildInfo, - -- ** Supplementary build information - HookedBuildInfo, - emptyHookedBuildInfo, - readHookedBuildInfo, - parseHookedBuildInfo, - writeHookedBuildInfo, - showHookedBuildInfo, - updatePackageDescription, - -- * Utilities - ParseResult(..), - PError, PWarning, showError, - hcOptions, - autogenModuleName, - haddockName, -#ifdef DEBUG - hunitTests, - test -#endif - ) where - -import Control.Monad(liftM, foldM, when) -import Data.Char -import Data.Maybe(fromMaybe, isNothing, catMaybes) -import Data.List (nub,lookup) -import Text.PrettyPrint.HughesPJ -import System.Directory(doesFileExist) -import System.Environment(getProgName) -import System.IO(hPutStrLn, stderr) -import System.Exit - -import Distribution.ParseUtils -import Distribution.Package(PackageIdentifier(..),showPackageId, - parsePackageName) -import Distribution.Version(Version(..), VersionRange(..), withinRange, - showVersion, parseVersion, showVersionRange, parseVersionRange) -import Distribution.License(License(..)) -import Distribution.Version(Dependency(..)) -import Distribution.Compiler(CompilerFlavor(..)) -import Distribution.Simple.Utils(currentDir, die, dieWithLocation, warn) -import Language.Haskell.Extension(Extension(..)) - -import Distribution.Compat.ReadP as ReadP hiding (get) -import Distribution.Compat.FilePath(joinFileExt) - -#ifdef DEBUG -import HUnit (Test(..), assertBool, Assertion, runTestTT, Counts, assertEqual) -import Distribution.ParseUtils (runP) -#endif - --- |Fix. Figure out a way to get this from .cabal file -cabalVersion :: Version -cabalVersion = Version [1,1,6] [] - --- | 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. - -- components - library :: Maybe Library, - executables :: [Executable], - dataFiles :: [FilePath], - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath] - } - deriving (Show, Read, Eq) - -data Library = Library { - exposedModules :: [String], - libBuildInfo :: BuildInfo - } - deriving (Show, Eq, Read) - -emptyLibrary :: Library -emptyLibrary = Library [] emptyBuildInfo - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription {package = PackageIdentifier "" (Version [] []), - license = AllRightsReserved, - licenseFile = "", - descCabalVersion = AnyVersion, - copyright = "", - maintainer = "", - author = "", - stability = "", - testedWith = [], - buildDepends = [], - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - library = Nothing, - executables = [], - dataFiles = [], - extraSrcFiles = [], - extraTmpFiles = [] - } - --- |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 - --- |Get all the module names from the exes in this package -exeModules :: PackageDescription -> [String] -exeModules PackageDescription{executables=execs} - = concatMap (otherModules . buildInfo) execs - --- |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) - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - buildable :: Bool, -- ^ component is buildable here - ccOptions :: [String], -- ^ options for C compiler - ldOptions :: [String], -- ^ options for linker - 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] - } - deriving (Show,Read,Eq) - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = BuildInfo { - buildable = True, - ccOptions = [], - ldOptions = [], - frameworks = [], - cSources = [], - hsSourceDirs = [currentDir], - otherModules = [], - extensions = [], - extraLibs = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - installIncludes = [], - options = [], - ghcProfOptions = [] - } - -data Executable = Executable { - exeName :: String, - modulePath :: FilePath, - buildInfo :: BuildInfo - } - deriving (Show, Read, Eq) - -emptyExecutable :: Executable -emptyExecutable = Executable { - exeName = "", - modulePath = "", - buildInfo = emptyBuildInfo - } - --- | 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)] - -type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - --- |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) - -setupMessage :: String -> PackageDescription -> IO () -setupMessage msg pkg_descr = - putStrLn (msg ++ ' ':showPackageId (package pkg_descr) ++ "...") - --- |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, - ccOptions = combine ccOptions, - ldOptions = combine ldOptions, - 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 = - joinFileExt (pkgName (package pkg_descr)) "haddock" - --- ------------------------------------------------------------ --- * Parsing & Pretty printing --- ------------------------------------------------------------ - --- the strings for the required fields are necessary here, and so we --- don't repeat ourselves, I name them: - -reqNameName = "name" -reqNameVersion = "version" -reqNameCopyright = "copyright" -reqNameMaintainer = "maintainer" -reqNameSynopsis = "synopsis" - -basicStanzaFields :: [StanzaField PackageDescription] -basicStanzaFields = - [ 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 "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}) - ] - -executableStanzaFields :: [StanzaField Executable] -executableStanzaFields = - [ simpleField "executable" - showFreeText (munch (const True)) - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" - showFilePath parseFilePathQ - modulePath (\xs exe -> exe{modulePath=xs}) - ] - -binfoFields :: [StanzaField BuildInfo] -binfoFields = - [ simpleField "buildable" - (text . show) parseReadS - buildable (\val binfo -> binfo{buildable=val}) - , listField "cc-options" - showToken parseTokenQ - ccOptions (\val binfo -> binfo{ccOptions=val}) - , listField "ld-options" - showToken parseTokenQ - ldOptions (\val binfo -> binfo{ldOptions=val}) - , 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 - includes (\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}) - , optsField "ghc-options" GHC - options (\path binfo -> binfo{options=path}) - , optsField "hugs-options" Hugs - options (\path binfo -> binfo{options=path}) - , optsField "nhc-options" NHC - options (\path binfo -> binfo{options=path}) - , optsField "jhc-options" JHC - options (\path binfo -> binfo{options=path}) - ] - - --- -------------------------------------------- --- ** Parsing - --- | Given a parser and a filename, return the parse of the file, --- after checking if the file exists. -readAndParseFile :: (String -> ParseResult a) -> FilePath -> IO a -readAndParseFile 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 (lineNo, message) = locatedErrorMsg e - dieWithLocation fpath lineNo message - ParseOk ws x -> do - mapM_ warn ws - return x - --- |Parse the given package file. -readPackageDescription :: FilePath -> IO PackageDescription -readPackageDescription = readAndParseFile parseDescription - -readHookedBuildInfo :: FilePath -> IO HookedBuildInfo -readHookedBuildInfo = readAndParseFile parseHookedBuildInfo - -parseDescription :: String -> ParseResult PackageDescription -parseDescription inp = do (st:sts) <- splitStanzas inp - pkg <- foldM (parseBasicStanza basicStanzaFields) emptyPackageDescription st - exes <- mapM parseExecutableStanza sts - return pkg{executables=exes} - where -- The basic stanza, with library building info - parseBasicStanza ((StanzaField name _ set):fields) pkg (lineNo, f, val) - | name == f = set lineNo val pkg - | otherwise = parseBasicStanza fields pkg (lineNo, f, val) - {- - , listField "exposed-modules" - text parseModuleNameQ - (\p -> maybe [] exposedModules (library p)) - (\xs pkg -> let lib = fromMaybe emptyLibrary (library pkg) in - pkg{library = Just lib{exposedModules=xs}}) --} - parseBasicStanza [] pkg (lineNo, f, val) - | "exposed-modules" == f = do - mods <- runP lineNo f (parseOptCommaList parseModuleNameQ) val - return pkg{library=Just lib{exposedModules=mods}} - | otherwise = do - bi <- parseBInfoField binfoFields (libBuildInfo lib) (lineNo, f, val) - return pkg{library=Just lib{libBuildInfo=bi}} - where - lib = fromMaybe emptyLibrary (library pkg) - - parseExecutableStanza st@((lineNo, "executable",eName):_) = - case lookupField "main-is" st of - Just (_,_) -> foldM (parseExecutableField executableStanzaFields) emptyExecutable st - Nothing -> syntaxError lineNo $ "No 'Main-Is' field found for " ++ eName ++ " stanza" - parseExecutableStanza ((lineNo, f,_):_) = - syntaxError lineNo $ "'Executable' stanza starting with field '" ++ f ++ "'" - parseExecutableStanza _ = error "This shouldn't happen!" - - parseExecutableField ((StanzaField name _ set):fields) exe (lineNo, f, val) - | name == f = set lineNo val exe - | otherwise = parseExecutableField fields exe (lineNo, f, val) - parseExecutableField [] exe (lineNo, f, val) = do - binfo <- parseBInfoField binfoFields (buildInfo exe) (lineNo, f, val) - return exe{buildInfo=binfo} - - -- ... - lookupField :: String -> Stanza -> Maybe (LineNo,String) - lookupField x sts = lookup x (map (\(n,f,v) -> (f,(n,v))) sts) - - -parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo -parseHookedBuildInfo inp = do - stanzas@(mLibStr:exes) <- splitStanzas inp - mLib <- parseLib mLibStr - biExes <- mapM parseExe (maybe stanzas (const exes) mLib) - return (mLib, biExes) - where - parseLib :: Stanza -> ParseResult (Maybe BuildInfo) - parseLib (bi@((_, inFieldName, _):_)) - | map toLower inFieldName /= "executable" = liftM Just (parseBI bi) - parseLib _ = return Nothing - parseExe :: Stanza -> ParseResult (String, BuildInfo) - parseExe ((lineNo, inFieldName, mName):bi) - | map toLower inFieldName == "executable" - = do bis <- parseBI bi - return (mName, bis) - | otherwise = syntaxError lineNo "expecting 'executable' at top of stanza" - parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" - parseBI :: Stanza -> ParseResult BuildInfo - parseBI st = foldM (parseBInfoField binfoFields) emptyBuildInfo st - -parseBInfoField :: [StanzaField a] -> a -> (LineNo, String, String) -> ParseResult a -parseBInfoField ((StanzaField name _ set):fields) binfo (lineNo, f, val) - | name == f = set lineNo val binfo - | otherwise = parseBInfoField fields binfo (lineNo, f, val) --- ignore "x-" extension fields without a warning -parseBInfoField [] binfo (lineNo, 'x':'-':f, _) = return binfo -parseBInfoField [] binfo (lineNo, f, _) = do - warning $ "Unknown field '" ++ f ++ "'" - return binfo - --- -------------------------------------------- --- ** Pretty printing - -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeFile fpath (showPackageDescription pkg) - -showPackageDescription :: PackageDescription -> String -showPackageDescription pkg = render $ - ppFields pkg basicStanzaFields $$ - (case library pkg of - Nothing -> empty - Just lib -> - text "exposed-modules" <> colon <+> fsep (punctuate comma (map text (exposedModules lib))) $$ - ppFields (libBuildInfo lib) binfoFields) $$ - vcat (map ppExecutable (executables pkg)) - where - ppExecutable exe = - space $$ - ppFields exe executableStanzaFields $$ - ppFields (buildInfo exe) binfoFields - - ppFields _ [] = empty - ppFields pkg' ((StanzaField name get _):flds) = - ppField name (get pkg') $$ ppFields pkg' flds - -ppField name field = text name <> colon <+> field - -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 binfoFields) $$ - vcat (map ppExeBuildInfo ex_bi) - where - ppExeBuildInfo (name, bi) = - space $$ - text "executable:" <+> text name $$ - ppFields bi binfoFields - - ppFields _ [] = empty - ppFields bi ((StanzaField name get _):flds) = - ppField name (get bi) $$ ppFields bi flds - - --- ------------------------------------------------------------ --- * 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." - allRights = checkSanity (license pkg_descr == AllRightsReserved) - "Package is copyright All Rights Reserved" - 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 verion: " ++ (showVersionRange v) ++ ".") - - in return $ (catMaybes [nothingToDo, noModules, - allRights, noLicenseFile] - ,catMaybes $ libSane:goodCabal:(checkMissingFields pkg_descr)) - --- |Output warnings and errors. Exit if any errors. -errorOut :: [String] -- ^Warnings - -> [String] -- ^errors - -> IO () -errorOut warnings errors = do - mapM warn warnings - when (not (null errors)) $ do - pname <- getProgName - mapM (hPutStrLn stderr . ((pname ++ ": Error: ") ++)) errors - exitWith (ExitFailure 1) - -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 = - ml >>= (\l -> - toMaybe (null $ exposedModules l) - ("Non-empty library, but empty exposed modules list. " ++ - "Cabal may not build this library correctly")) - -checkSanity :: Bool -> String -> Maybe String -checkSanity = toMaybe - -hasMods :: PackageDescription -> Bool -hasMods pkg_descr = - null (executables pkg_descr) && - maybe True (null . exposedModules) (library pkg_descr) - - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ -#ifdef DEBUG -testPkgDesc :: String -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: " - ] - -testPkgDescAnswer :: PackageDescription -testPkgDescAnswer = - 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] []), - 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"], - -- Note reversed order: - ghcProfOptions = [], - options = [(JHC,[]),(NHC, []), (Hugs,["+TH"]), (GHC,["-fTH","-fglasgow-exts"])]} - }, - executables = [Executable "somescript" - "SomeFile.hs" ( - emptyBuildInfo{ - otherModules=["Foo1","Util","Main"], - hsSourceDirs = ["scripts"], - extensions = [OverlappingInstances], - options = [(JHC,[]),(NHC,[]),(Hugs,[]),(GHC,[])] - })] -} - -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"]))} - (parseDescription "Name: foo\nVersion: 0.0-asdf") - - assertParseOk "more fields foo" - emptyPackageDescription{package=(PackageIdentifier "foo" - (Version [0,0]["asdf"])), - license=GPL} - (parseDescription "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"} - (parseDescription "Name: foo\nVersion:0.0-asdf\nCopyright: 2004 isaac jones\nLicense: GPL"), - - TestCase $ assertParseOk "no library" Nothing - (library `liftM` parseDescription "Name: foo\nVersion: 1\nLicense: GPL\nMaintainer: someone\n\nExecutable: script\nMain-is: SomeFile.hs\n"), - - TestLabel "Package description" $ TestCase $ - assertParseOk "entire package description" testPkgDescAnswer - (parseDescription testPkgDesc), - TestLabel "Package description pretty" $ TestCase $ - case parseDescription testPkgDesc of - ParseFailed _ -> assertBool "can't parse description" False - ParseOk _ d -> case parseDescription $ showPackageDescription d of - ParseFailed _ -> - assertBool "can't parse description after pretty print!" False - ParseOk _ d' -> - assertBool ("parse . show . parse not identity." - ++" Incorrect fields:" - ++ (show $ 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" 4 (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":[] - - - where myCmp :: (Eq a, Show a) => (PackageDescription -> a) - -> String -- Error message - -> Maybe String -- - myCmp f er = let e1 = f p1 - e2 = f p2 - in toMaybe (e1 /= e2) - (er ++ " Expected: " ++ show e1 - ++ " Got: " ++ show e2) - --- |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) -#endif + 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((<.>)) + +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 + = if null (modulePath exe) + then Just ("No 'Main-Is' field found for executable " ++ exeName exe + ++ "Fields of the executable section:\n" + ++ (render $ nest 4 $ ppFields exe executableFieldDescrs)) + else Nothing + +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 + diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ParseUtils @@ -44,36 +45,46 @@ -- #hide module Distribution.ParseUtils ( - LineNo, PError(..), PWarning, - locatedErrorMsg, showError, syntaxError, warning, - runP, ParseResult(..), - StanzaField(..), splitStanzas, Stanza, singleStanza, + LineNo, PError(..), PWarning, locatedErrorMsg, syntaxError, warning, + runP, ParseResult(..), catchParseError, parseFail, + Field(..), fName, lineNo, + FieldDescr(..), readFields, parseFilePathQ, parseTokenQ, - parseModuleNameQ, parseDependency, parseOptVersion, - parsePackageNameQ, parseVersionRangeQ, - parseTestedWithQ, parseLicenseQ, parseExtensionQ, parseCommaList, parseOptCommaList, + parseModuleNameQ, parseDependency, parsePkgconfigDependency, + parseOptVersion, parsePackageNameQ, parseVersionRangeQ, + parseTestedWithQ, parseLicenseQ, parseExtensionQ, + parseSepList, parseCommaList, parseOptCommaList, showFilePath, showToken, showTestedWith, showDependency, showFreeText, - simpleField, listField, commaListField, optsField, - parseReadS, parseQuoted, + field, simpleField, listField, commaListField, optsField, liftField, + parseReadS, parseReadSQ, parseQuoted, ) where -import Text.PrettyPrint.HughesPJ import Distribution.Compiler (CompilerFlavor) import Distribution.License import Distribution.Version import Distribution.Package ( parsePackageName ) import Distribution.Compat.ReadP as ReadP hiding (get) -import Distribution.Compat.FilePath (platformPath) -import Control.Monad (liftM) -import Data.Char 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 + -- ----------------------------------------------------------------------------- type LineNo = Int data PError = AmbigousParse String LineNo | NoParse String LineNo + | TabsError LineNo | FromString String (Maybe LineNo) deriving Show @@ -90,136 +101,355 @@ ParseOk ws' x' -> ParseOk (ws'++ws) x' fail s = ParseFailed (FromString s Nothing) +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a -runP lineNo field p s = +runP line fieldname p s = case [ x | (x,"") <- results ] of [a] -> ParseOk [] a [] -> case [ x | (x,ys) <- results, all isSpace ys ] of [a] -> ParseOk [] a - [] -> ParseFailed (NoParse field lineNo) - _ -> ParseFailed (AmbigousParse field lineNo) - _ -> ParseFailed (AmbigousParse field lineNo) + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) where results = readP_to_S p s --- TODO: deprecated -showError :: PError -> String -showError e = - case locatedErrorMsg e of - (Just n, s) -> "Line "++show n++": " ++ s - (Nothing, s) -> s - locatedErrorMsg :: PError -> (Maybe LineNo, String) -locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambigous parse in field '"++f++"'") +locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'") locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed: ") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") locatedErrorMsg (FromString s n) = (n, s) syntaxError :: LineNo -> String -> ParseResult a syntaxError n s = ParseFailed $ FromString s (Just n) +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + warning :: String -> ParseResult () warning s = ParseOk [s] () -data StanzaField a - = StanzaField +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr { fieldName :: String , fieldGet :: a -> Doc , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. } -simpleField :: String -> (a -> Doc) -> (ReadP a a) -> (b -> a) -> (a -> b -> b) -> StanzaField b -simpleField name showF readF get set = StanzaField name - (\st -> showF (get st)) - (\lineNo val st -> do - x <- runP lineNo name readF val - return (set x st)) +field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) -commaListField :: String -> (a -> Doc) -> (ReadP [a] a) -> (b -> [a]) -> ([a] -> b -> b) -> StanzaField b -commaListField name showF readF get set = StanzaField name - (\st -> fsep (punctuate comma (map showF (get st)))) - (\lineNo val st -> do - xs <- runP lineNo name (parseCommaList readF) val - return (set xs st)) +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (\b -> showF (get b)) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) -listField :: String -> (a -> Doc) -> (ReadP [a] a) -> (b -> [a]) -> ([a] -> b -> b) -> StanzaField b -listField name showF readF get set = StanzaField name - (\st -> fsep (map showF (get st))) - (\lineNo val st -> do - xs <- runP lineNo name (parseOptCommaList readF) val - return (set xs st)) +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> (ReadP a a) + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF -optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> StanzaField b -optsField name flavor get set = StanzaField name - (\st -> case lookup flavor (get st) of - Just args -> hsep (map text args) - Nothing -> empty) - (\_ val st -> - let - old_val = get st - old_args = case lookup flavor old_val of - Just args -> args - Nothing -> [] - val' = filter (\(f,_) -> f/=flavor) old_val - in return (set ((flavor,words val++old_args) : val') st)) +commaListField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField name showF readF get set = + liftField get set $ + field name (fsep . punctuate comma . map showF) (parseCommaList readF) -type Stanza = [(LineNo,String,String)] +listField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField name showF readF get set = + liftField get set $ + field name (fsep . map showF) (parseOptCommaList readF) --- |Split a string into blank line-separated stanzas of --- "Field: value" groups -splitStanzas :: String -> ParseResult [Stanza] -splitStanzas = mapM mkStanza . map merge . groupStanzas . filter validLine . zip [1..] . lines - where validLine (_,s) = case dropWhile isSpace s of - '-':'-':_ -> False -- Comment - _ -> True - groupStanzas :: [(Int,String)] -> [[(Int,String)]] - groupStanzas [] = [] - groupStanzas xs = let (ys,zs) = break allSpaces xs - in ys : groupStanzas (dropWhile allSpaces zs) +optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (update flavor opts (get b)) b) $ + field name (hsep . map text) + (sepBy parseTokenQ' (munch1 isSpace)) + where + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts ++ opts') : rest + | otherwise = (f',opts') : update f opts rest -allSpaces :: (a, String) -> Bool -allSpaces (_,xs) = all isSpace xs +------------------------------------------------------------------------------ --- |Split a file into "Field: value" groups, but blank lines have no --- significance, unlike 'splitStanzas'. A field value may span over blank --- lines. -singleStanza :: String -> ParseResult Stanza -singleStanza = mkStanza . merge . filter validLine . zip [1..] . lines - where validLine (_,s) = case dropWhile isSpace s of - '-':'-':_ -> False -- Comment - [] -> False -- blank line - _ -> True +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing -merge :: [(a, [Char])] -> [(a, [Char])] -merge ((n,x):(_,c:s):ys) - | c == ' ' || c == '\t' = case dropWhile isSpace s of - ('.':s') -> merge ((n,x++"\n"++s'):ys) - s' -> merge ((n,x++"\n"++s'):ys) -merge ((n,x):ys) = (n,x) : merge ys -merge [] = [] +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n -mkStanza :: [(Int,String)] -> ParseResult Stanza -mkStanza [] = return [] -mkStanza ((n,xs):ys) = - case break (==':') xs of - (fld', ':':val) -> do - let fld'' = map toLower fld' - fld <- case () of - _ | fld'' == "hs-source-dir" - -> do warning "The field \"hs-source-dir\" is deprecated, please use hs-source-dirs." - return "hs-source-dirs" - | fld'' == "other-files" - -> do warning "The field \"other-files\" is deprecated, please use extra-source-files." - return "extra-source-files" - | otherwise -> return fld'' - ss <- mkStanza ys - checkDuplField fld ss - return ((n, fld, dropWhile isSpace val):ss) - (_, _) -> syntaxError n "Invalid syntax (no colon after field name)" - where - checkDuplField _ [] = return () - checkDuplField fld ((n',fld',_):xs') - | fld' == fld = syntaxError (max n n') $ "The field "++fld++" was already defined on line " ++ show (min n n') - | otherwise = checkDuplField fld xs' +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" +readFields :: String -> ParseResult [Field] +readFields input = + ifelse + =<< mapM (mkField 0) + =<< mkTree (tokenise input) + + where tokenise = concatMap tokeniseLine + . trimLines + . lines + . normaliseLineEndings + -- TODO: should decode UTF8 + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is ok + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. +-- Also trims leading & trailing space on those spans within the line. +tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLine (n0, i, t, l) = case split n0 l of + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = reverse . dropWhile isSpace . reverse + + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +mkTree toks = + layout 0 [] toks >>= \(trees, trailing) -> case trailing of + [] -> return trees + OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {" + CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +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 + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- mapM (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in (concat . intersperse "\n") allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + -- |parse a module name parseModuleNameQ :: ReadP r String parseModuleNameQ = parseQuoted modu <++ modu @@ -229,7 +459,9 @@ return (c:cs) parseFilePathQ :: ReadP r FilePath -parseFilePathQ = liftM platformPath parseTokenQ +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ parseReadS :: Read a => ReadP r a parseReadS = readS_to_P reads @@ -241,6 +473,16 @@ skipSpaces return $ Dependency name ver +-- pkg-config allows versions and other letters in package names, +-- eg "gtk+-2.0" is a valid pkg-config package _name_. +-- It then has a package version number like 2.10.13 +parsePkgconfigDependency :: ReadP r Dependency +parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") + skipSpaces + ver <- parseVersionRangeQ <++ return AnyVersion + skipSpaces + return $ Dependency name ver + parsePackageNameQ :: ReadP r String parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName @@ -271,18 +513,29 @@ parseExtensionQ :: ReadP r Extension parseExtensionQ = parseQuoted parseReadS <++ parseReadS +-- | Parse something optionally wrapped in quotes. +parseReadSQ :: Read a => ReadP r a +parseReadSQ = parseQuoted parseReadS <++ parseReadS + parseTokenQ :: ReadP r String parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',') +parseTokenQ' :: ReadP r String +parseTokenQ' = parseReadS <++ munch1 (\x -> not (isSpace x)) + +parseSepList :: ReadP r b + -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSepList sepr p = sepBy p separator + where separator = skipSpaces >> sepr >> skipSpaces + parseCommaList :: ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] -parseCommaList p = sepBy p separator - where separator = skipSpaces >> ReadP.char ',' >> skipSpaces +parseCommaList = parseSepList (ReadP.char ',') parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseOptCommaList p = sepBy p separator - where separator = skipSpaces >> optional (ReadP.char ',') >> skipSpaces + -> ReadP r [a] +parseOptCommaList = parseSepList (optional (ReadP.char ',')) parseQuoted :: ReadP r a -> ReadP r a parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p @@ -310,3 +563,172 @@ -- 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/PreProcess.hs b/Distribution/PreProcess.hs deleted file mode 100644 --- a/Distribution/PreProcess.hs +++ /dev/null @@ -1,308 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PreProcess --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- -{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace -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.PreProcess (preprocessSources, knownSuffixHandlers, - ppSuffixes, PPSuffixHandler, PreProcessor, - removePreprocessed, removePreprocessedPackage, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit - ) - where - -import Distribution.PreProcess.Unlit(unlit) -import Distribution.PackageDescription (setupMessage, PackageDescription(..), - BuildInfo(..), Executable(..), withExe, - Library(..), withLib, libModules) -import Distribution.Compiler (CompilerFlavor(..), Compiler(..)) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Utils (rawSystemVerbose, - moduleToFilePath, die, dieWithLocation) -import Distribution.Version (Version(..)) -import Control.Monad (unless) -import Data.Maybe (fromMaybe) -import Data.List (nub) -import System.Exit (ExitCode(..)) -import System.Directory (removeFile, getModificationTime) -import System.Info (os, arch) -import Distribution.Compat.FilePath - (splitFileExt, joinFileName, joinFileExt) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler inFile outFile verbose --- > = do when (verbose > 0) $ --- > putStrLn (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess --- -type PreProcessor = FilePath -- Location of the source file in need of preprocessing - -> FilePath -- Output filename - -> Int -- verbose - -> IO ExitCode - - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) - --- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain --- a Haskell source file for each module. -preprocessSources :: PackageDescription - -> LocalBuildInfo - -> Int -- ^ verbose - -> [PPSuffixHandler] -- ^ preprocessors to try - -> IO () - -preprocessSources pkg_descr lbi verbose handlers = do - withLib pkg_descr () $ \ lib -> do - setupMessage "Preprocessing library" pkg_descr - let bi = libBuildInfo lib - let biHandlers = localHandlers bi - sequence_ [do retVal <- preprocessModule (hsSourceDirs bi) modu - verbose builtinSuffixes biHandlers - unless (retVal == ExitSuccess) - (die $ "got error code while preprocessing: " ++ modu) - | modu <- libModules pkg_descr] - unless (null (executables pkg_descr)) $ - setupMessage "Preprocessing executables for" pkg_descr - withExe pkg_descr $ \ theExe -> do - let bi = buildInfo theExe - let biHandlers = localHandlers bi - sequence_ [do retVal <- preprocessModule (nub $ (hsSourceDirs bi) - ++(maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr))) - modu verbose builtinSuffixes biHandlers - unless (retVal == ExitSuccess) - (die $ "got error code while preprocessing: " ++ modu) - | modu <- otherModules bi] - where hc = compilerFlavor (compiler lbi) - builtinSuffixes - | hc == NHC = ["hs", "lhs", "gc"] - | otherwise = ["hs", "lhs"] - localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] - --- |Find the first extension of the file that exists, and preprocess it --- if required. -preprocessModule - :: [FilePath] -- ^source directories - -> String -- ^module name - -> Int -- ^verbose - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> IO ExitCode -preprocessModule searchLoc modu verbose builtinSuffixes handlers = do - bsrcFiles <- moduleToFilePath searchLoc modu builtinSuffixes - psrcFiles <- moduleToFilePath searchLoc modu (map fst handlers) - case psrcFiles of - [] -> case bsrcFiles of - [] -> die ("can't find source for " ++ modu ++ " in " ++ show searchLoc) - _ -> return ExitSuccess - (psrcFile:_) -> do - let (srcStem, ext) = splitFileExt psrcFile - pp = fromMaybe (error "Internal error in preProcess module: Just expected") - (lookup ext handlers) - recomp <- case bsrcFiles of - [] -> return True - (bsrcFile:_) -> do - btime <- getModificationTime bsrcFile - ptime <- getModificationTime psrcFile - return (btime < ptime) - if recomp - then pp psrcFile (srcStem `joinFileExt` "hs") verbose - else return ExitSuccess - -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 (joinFileName r) (hsSourceDirs bi)) (libModules pkg_descr) suff) - withExe pkg_descr (\theExe -> do - let bi = buildInfo theExe - removePreprocessed (map (joinFileName 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 --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppGreenCard = ppGreenCard' [] - -ppGreenCard' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppGreenCard' inputArgs bi lbi - = maybe (ppNone "greencard") pp (withGreencard lbi) - where pp greencard inFile outFile verbose - = rawSystemVerbose verbose greencard (["-tffi", "-o" ++ outFile, inFile] ++ inputArgs) - --- This one is useful for preprocessors that can't handle literate source. --- We also need a way to chain preprocessors. -ppUnlit :: PreProcessor -ppUnlit inFile outFile verbose = do - contents <- readFile inFile - writeFile outFile (unlit inFile contents) - return ExitSuccess - -ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp' inputArgs bi lbi = - case withCpphs lbi of - Just path -> use_cpphs path - Nothing | compilerFlavor hc == GHC -> use_ghc - _otherwise -> ppNone "cpphs (or GHC)" - where - hc = compiler lbi - - use_cpphs cpphs inFile outFile verbose - = rawSystemVerbose verbose cpphs cpphsArgs - where cpphsArgs = ("-O"++outFile) : inFile : "--noline" : "--strip" - : extraArgs - - extraArgs = sysDefines ++ cppOptions bi lbi ++ inputArgs - - sysDefines = - ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] ++ - ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] - locations = ["BUILD", "HOST"] - - use_ghc inFile outFile verbose - = rawSystemVerbose verbose (compilerPath hc) - (["-E", "-cpp", "-optP-P", "-o", outFile, inFile] ++ extraArgs) - -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi - = maybe (ppNone "hsc2hs") pp (withHsc2hs lbi) - where pp n = standardPP n (hcDefines (compiler lbi) - ++ ["-I" ++ dir | dir <- includeDirs bi] - ++ [opt | opt@('-':c:_) <- ccOptions bi, c == 'D' || c == 'I'] - ++ ["--cflag=" ++ opt | opt@('-':'U':_) <- ccOptions bi] - ++ ["--lflag=-L" ++ dir | dir <- extraLibDirs bi] - ++ ["--lflag=-l" ++ lib | lib <- extraLibs bi]) - -ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppC2hs bi lbi - = maybe (ppNone "c2hs") pp (withC2hs lbi) - where pp n = standardPP n (concat [["-C", opt] | opt <- cppOptions bi lbi]) - -cppOptions :: BuildInfo -> LocalBuildInfo -> [String] -cppOptions bi lbi - = hcDefines (compiler lbi) ++ - ["-I" ++ dir | dir <- includeDirs bi] ++ - [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"] - -hcDefines :: Compiler -> [String] -hcDefines Compiler { compilerFlavor=GHC, compilerVersion=version } - = ["-D__GLASGOW_HASKELL__=" ++ versionInt version] -hcDefines Compiler { compilerFlavor=JHC, compilerVersion=version } - = ["-D__JHC__=" ++ versionInt version] -hcDefines Compiler { compilerFlavor=NHC, compilerVersion=version } - = ["-D__NHC__=" ++ versionInt version] -hcDefines Compiler { compilerFlavor=Hugs } - = ["-D__HUGS__"] -hcDefines _ = [] - -versionInt :: Version -> String -versionInt (Version { versionBranch = [] }) = "1" -versionInt (Version { versionBranch = [n] }) = show n -versionInt (Version { versionBranch = n1:n2:_ }) - = show n1 ++ take 2 ('0' : show n2) - -ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHappy _ lbi - = maybe (ppNone "happy") pp (withHappy lbi) - where pp n = standardPP n (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppAlex _ lbi - = maybe (ppNone "alex") pp (withAlex lbi) - where pp n = standardPP n (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags _ = [] - -standardPP :: String -> [String] -> PreProcessor -standardPP eName args inFile outFile verbose - = rawSystemVerbose verbose eName (args ++ ["-o", outFile, inFile]) - -ppNone :: String -> PreProcessor -ppNone name inFile _ _ = - dieWithLocation inFile Nothing $ "no " ++ name ++ " preprocessor available" - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] -ppSuffixes = map fst - --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] -knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) - ] diff --git a/Distribution/PreProcess/Unlit.hs b/Distribution/PreProcess/Unlit.hs deleted file mode 100644 --- a/Distribution/PreProcess/Unlit.hs +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PreProcess.Unlit --- Copyright : ... --- --- Maintainer : Malcolm Wallace --- Stability : Stable --- Portability : portable --- --- 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.PreProcess.Unlit(unlit,plain) where - -import Data.Char - --- exports: - -unlit :: String -> String -> String -unlit file lhs = (unlines . map unclassify . adjacent file (0::Int) Blank - . classify 0) (tolines lhs) - -plain :: String -> String -> String -- no unliteration -plain _ hs = hs ----- - -data Classified = Program String | Blank | Comment - | Include Int String | Pre String - -classify :: Int -> [String] -> [Classified] -classify _ [] = [] -classify _ (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs - where allProg [] = [] -- Should give an error message, but I have no - -- good position information. - allProg (('\\':x'):xs') | x' == "end{code}" = Blank : classify 0 xs' - allProg (x':xs') = Program x':allProg xs' -classify 0 (('>':x):xs) = let (sp,code) = span isSpace x in - Program code : classify (length sp + 1) xs -classify n (('>':x):xs) = Program (drop (n-1) x) : classify n xs -classify _ (('#':x):xs) = - (case words x of - (line:file:_) | all isDigit line -> Include (read line) file - _ -> Pre x - ) : classify 0 xs -classify _ (x:xs) | all isSpace x = Blank:classify 0 xs -classify _ (_:xs) = Comment:classify 0 xs - -unclassify :: Classified -> String -unclassify (Program s) = s -unclassify (Pre s) = '#':s -unclassify (Include i f) = '#':' ':show i ++ ' ':f -unclassify Blank = "" -unclassify Comment = "" - -adjacent :: String -> Int -> Classified -> [Classified] -> [Classified] -adjacent file 0 _ (x :xs) = x: adjacent file 1 x xs - -- force evaluation of line number -adjacent file n (Program _) (Comment :_) = - error (message file n "program" "comment") -adjacent _ _ y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@(Program _) (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n Comment ((Program _) :_) = - error (message file n "comment" "program") -adjacent _ _ y@Comment (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@Comment (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent _ _ y@Blank (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@Blank (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n _ (x :xs) = x: adjacent file (n+1) x xs -adjacent _ _ _ [] = [] - -message :: (Show a) => String -> a -> 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" - - --- Re-implementation of 'lines', for better efficiency (but decreased --- laziness). Also, importantly, accepts non-standard DOS and Mac line --- ending characters. -tolines :: String -> [String] -tolines s' = lines' s' 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' (c:s) acc = lines' s (acc . (c:)) - - - -{- --- A very naive version of unliteration.... -module Unlit(unlit) where --- This version does not handle \begin{code} & \end{code}, and it is --- careless with indentation. -unlit = map unlitline - -unlitline ('>' : s) = s -unlitline _ = "" --} - diff --git a/Distribution/Program.hs b/Distribution/Program.hs deleted file mode 100644 --- a/Distribution/Program.hs +++ /dev/null @@ -1,280 +0,0 @@ -module Distribution.Program( Program(..) - , ProgramLocation(..) - , ProgramConfiguration(..) - , withProgramFlag - , programOptsFlag - , programOptsField - , defaultProgramConfiguration - , updateProgram - , userSpecifyPath - , userSpecifyArgs - , lookupProgram - , lookupPrograms - , rawSystemProgram - , rawSystemProgramConf - , simpleProgram - -- Programs - , ghcProgram - , ghcPkgProgram - , nhcProgram - , jhcProgram - , hugsProgram - , ranlibProgram - , arProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , haddockProgram - , greencardProgram - , ldProgram - , cppProgram - , pfesetupProgram - ) where - -import qualified Distribution.Compat.Map as Map -import Control.Monad(when) -import Data.Maybe(catMaybes) -import System.Exit (ExitCode) -import Distribution.Compat.Directory(findExecutable) -import Distribution.Simple.Utils (die, rawSystemVerbose, maybeExit) - --- |Represents a program which cabal may call. -data Program - = Program { -- |The simple name of the program, eg ghc - programName :: String - -- |The name of this program's binary, eg ghc-6.4 - ,programBinName :: String - -- |Default command-line args for this program - ,programArgs :: [String] - -- |Location of the program. eg. \/usr\/bin\/ghc-6.4 - ,programLocation :: ProgramLocation - } deriving (Read, Show) - --- |Similar to Maybe, but tells us whether it's specifed by user or --- not. This includes not just the path, but the program as well. -data ProgramLocation = EmptyLocation - | UserSpecified FilePath - | FoundOnSystem FilePath - deriving (Read, Show) - -data ProgramConfiguration = ProgramConfiguration (Map.Map String Program) - --- Read & Show instances are based on listToFM - -instance Show ProgramConfiguration where - show (ProgramConfiguration s) = show $ Map.toAscList s - -instance Read ProgramConfiguration where - readsPrec p s = [(ProgramConfiguration $ Map.fromList $ s', r) - | (s', r) <- readsPrec p s ] - --- |The default list of programs and their arguments. These programs --- are typically used internally to Cabal. - -defaultProgramConfiguration :: ProgramConfiguration -defaultProgramConfiguration = progListToFM - [ haddockProgram - , pfesetupProgram - , ranlibProgram - , simpleProgram "runghc" - , simpleProgram "runhugs" - , arProgram] --- haddock is currently the only one that really works. -{- [ ghcProgram - , ghcPkgProgram - , nhcProgram - , hugsProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , haddockProgram - , greencardProgram - , ldProgram - , cppProgram - , pfesetupProgram - , ranlib, ar - ]-} - --- |The flag for giving a path to this program. eg --with-alex=\/usr\/bin\/alex -withProgramFlag :: Program -> String -withProgramFlag Program{programName=n} = "with-" ++ n - --- |The flag for giving args for this program. --- eg --haddock-options=-s http:\/\/foo -programOptsFlag :: Program -> String -programOptsFlag Program{programName=n} = n ++ "-options" - --- |The foo.cabal field for giving args for this program. --- eg haddock-options: -s http:\/\/foo -programOptsField :: Program -> String -programOptsField = programOptsFlag - --- ------------------------------------------------------------ --- * cabal programs --- ------------------------------------------------------------ - -ghcProgram :: Program -ghcProgram = simpleProgram "ghc" - -ghcPkgProgram :: Program -ghcPkgProgram = simpleProgram "ghc-pkg" - -nhcProgram :: Program -nhcProgram = simpleProgram "nhc" - -jhcProgram :: Program -jhcProgram = simpleProgram "jhc" - -hugsProgram :: Program -hugsProgram = simpleProgram "hugs" - -alexProgram :: Program -alexProgram = simpleProgram "alex" - -ranlibProgram :: Program -ranlibProgram = simpleProgram "ranlib" - -arProgram :: Program -arProgram = simpleProgram "ar" - -hsc2hsProgram :: Program -hsc2hsProgram = simpleProgram "hsc2hs" - -c2hsProgram :: Program -c2hsProgram = simpleProgram "c2hs" - -cpphsProgram :: Program -cpphsProgram = simpleProgram "cpphs" - -haddockProgram :: Program -haddockProgram = simpleProgram "haddock" - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" - -ldProgram :: Program -ldProgram = simpleProgram "ld" - -cppProgram :: Program -cppProgram = simpleProgram "cpp" - -pfesetupProgram :: Program -pfesetupProgram = simpleProgram "pfesetup" - --- ------------------------------------------------------------ --- * helpers --- ------------------------------------------------------------ - --- |Looks up a program in the given configuration. If there's no --- location information in the configuration, then we use IO to look --- on the system in PATH for the program. If the program is not in --- the configuration at all, we return Nothing. FIX: should we build --- a simpleProgram in that case? Do we want a way to specify NOT to --- find it on the system (populate programLocation). - -lookupProgram :: String -- simple name of program - -> ProgramConfiguration - -> IO (Maybe Program) -- the full program -lookupProgram name conf = - case lookupProgram' name conf of - Nothing -> return Nothing - Just p@Program{ programLocation= configLoc - , programBinName = binName} - -> do newLoc <- case configLoc of - EmptyLocation - -> do maybeLoc <- findExecutable binName - return $ maybe EmptyLocation FoundOnSystem maybeLoc - a -> return a - return $ Just p{programLocation=newLoc} - -lookupPrograms :: ProgramConfiguration -> IO [(String, Maybe Program)] -lookupPrograms conf@(ProgramConfiguration fm) = do - let l = Map.elems fm - mapM (\p -> do fp <- lookupProgram (programName p) conf - return (programName p, fp) - ) l - --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program, add it. -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to filename - -> ProgramConfiguration - -> ProgramConfiguration -userSpecifyPath name path conf'@(ProgramConfiguration conf) - = case Map.lookup name conf of - Just p -> updateProgram (Just p{programLocation=UserSpecified path}) conf' - Nothing -> updateProgram (Just $ Program name name [] (UserSpecified path)) - conf' - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, add it. -userSpecifyArgs :: String -- ^Program name - -> String -- ^user-specified args - -> ProgramConfiguration - -> ProgramConfiguration -userSpecifyArgs name args conf'@(ProgramConfiguration conf) - = case Map.lookup name conf of - Just p -> updateProgram (Just p{programArgs=(words args)}) conf' - Nothing -> updateProgram (Just $ Program name name (words args) EmptyLocation) conf' - --- |Update this program's entry in the configuration. No changes if --- you pass in Nothing. -updateProgram :: Maybe Program -> ProgramConfiguration -> ProgramConfiguration -updateProgram (Just p@Program{programName=n}) (ProgramConfiguration conf) - = ProgramConfiguration $ Map.insert n p conf -updateProgram Nothing conf = conf - --- |Runs the given program. -rawSystemProgram :: Int -- ^Verbosity - -> Program -- ^The program to run - -> [String] -- ^Any /extra/ arguments to add - -> IO () -rawSystemProgram verbose (Program { programLocation=(UserSpecified p) - , programArgs=args - }) extraArgs - = maybeExit $ rawSystemVerbose verbose p (extraArgs ++ args) - -rawSystemProgram verbose (Program { programLocation=(FoundOnSystem p) - , programArgs=args - }) extraArgs - = maybeExit $ rawSystemVerbose verbose p (args ++ extraArgs) - -rawSystemProgram _ (Program { programLocation=EmptyLocation - , programName=n}) _ - = die ("Error: Could not find location for program: " ++ n) - -rawSystemProgramConf :: Int -- ^verbosity - -> String -- ^The name of the program to run - -> ProgramConfiguration -- ^look up the program here - -> [String] -- ^Any /extra/ arguments to add - -> IO () -rawSystemProgramConf verbose progName programConf extraArgs - = do prog <- do mProg <- lookupProgram progName programConf - case mProg of - Nothing -> (die (progName ++ " command not found")) - Just h -> return h - rawSystemProgram verbose prog extraArgs - - --- ------------------------------------------------------------ --- * Internal helpers --- ------------------------------------------------------------ - --- Export? -lookupProgram' :: String -> ProgramConfiguration -> Maybe Program -lookupProgram' s (ProgramConfiguration conf) = Map.lookup s conf - -progListToFM :: [Program] -> ProgramConfiguration -progListToFM progs = foldl - (\ (ProgramConfiguration conf') - p@(Program {programName=n}) - -> ProgramConfiguration (Map.insert n p conf')) - (ProgramConfiguration Map.empty) - progs - -simpleProgram :: String -> Program -simpleProgram s = Program s s [] EmptyLocation diff --git a/Distribution/Setup.hs b/Distribution/Setup.hs --- a/Distribution/Setup.hs +++ b/Distribution/Setup.hs @@ -1,808 +1,5 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.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.Setup (--parseArgs, - module Distribution.Compiler, - Action(..), - ConfigFlags(..), emptyConfigFlags, configureArgs, - CopyFlags(..), CopyDest(..), - InstallFlags(..), emptyInstallFlags, - HaddockFlags(..), emptyHaddockFlags, - BuildFlags(..), CleanFlags(..), PFEFlags(..), - RegisterFlags(..), emptyRegisterFlags, - SDistFlags(..), - MaybeUserFlag(..), userOverride, - --optionHelpString, -#ifdef DEBUG - hunitTests, -#endif - parseGlobalArgs, defaultCompilerFlavor, - parseConfigureArgs, parseBuildArgs, parseCleanArgs, - parseHaddockArgs, parseProgramaticaArgs, parseTestArgs, - parseInstallArgs, parseSDistArgs, parseRegisterArgs, - parseUnregisterArgs, parseCopyArgs, - reqPathArg, reqDirArg - ) where - - --- Misc: -#ifdef DEBUG -import HUnit (Test(..)) -#endif - -import Distribution.Compiler (CompilerFlavor(..), Compiler(..)) -import Distribution.Simple.Utils (die) -import Distribution.Program(ProgramConfiguration(..), - userSpecifyPath, userSpecifyArgs) -import Data.List(find) -import Distribution.Compat.Map (keys) -import Distribution.GetOpt -import Distribution.Compat.FilePath (platformPath) -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) - | HaddockCmd -- haddock - | ProgramaticaCmd -- pfesetup - | InstallCmd -- install (install-prefix) - | SDistCmd -- sdist - | TestCmd -- test - | RegisterCmd -- register - | UnregisterCmd -- unregister - | HelpCmd -- help --- | NoCmd -- error case, help case. --- | TestCmd 1.0? --- | BDist -- 1.0 --- | CleanCmd -- clean --- | NoCmd -- error case? - --- ------------------------------------------------------------ --- * Flag-related types --- ------------------------------------------------------------ - --- | Flags to @configure@ command -data ConfigFlags = ConfigFlags { - configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run - configHcFlavor :: Maybe CompilerFlavor, - configHcPath :: Maybe FilePath, -- ^given compiler location - configHcPkg :: Maybe FilePath, -- ^given hc-pkg location - configHappy :: Maybe FilePath, -- ^Happy path - configAlex :: Maybe FilePath, -- ^Alex path - configHsc2hs :: Maybe FilePath, -- ^Hsc2hs path - configC2hs :: Maybe FilePath, -- ^C2hs path - configCpphs :: Maybe FilePath, -- ^Cpphs path - configGreencard:: Maybe FilePath, -- ^GreenCard path - configVanillaLib :: Bool, -- ^Enable vanilla library - configProfLib :: Bool, -- ^Enable profiling in the library - configProfExe :: Bool, -- ^Enable profiling in the executables. - 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 - - configVerbose :: Int, -- ^verbosity level - configUser :: Bool, -- ^--user flag? - configGHCiLib :: Bool, -- ^Enable compiling library for GHCi - configSplitObjs :: Bool -- ^Enable -split-objs with GHC - } - -emptyConfigFlags :: ProgramConfiguration -> ConfigFlags -emptyConfigFlags progConf = ConfigFlags { - configPrograms = progConf, - configHcFlavor = defaultCompilerFlavor, - configHcPath = Nothing, - configHcPkg = Nothing, --- configHaddock = EmptyLocation, - configHappy = Nothing, - configAlex = Nothing, - configHsc2hs = Nothing, - configC2hs = Nothing, - configVanillaLib = True, - configProfLib = False, - configProfExe = False, - configCpphs = Nothing, - configGreencard= Nothing, - configPrefix = Nothing, - configBinDir = Nothing, - configLibDir = Nothing, - configLibSubDir = Nothing, - configLibExecDir = Nothing, - configDataDir = Nothing, - configDataSubDir = Nothing, - configVerbose = 0, - configUser = False, - configGHCiLib = True, - configSplitObjs = False -- takes longer, so turn off by default - } - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbose) -data CopyFlags = CopyFlags {copyDest :: CopyDest - ,copyVerbose :: Int} - -data CopyDest - = NoCopyDest - | CopyTo FilePath - | CopyPrefix FilePath -- DEPRECATED - deriving (Eq, Show) - -data MaybeUserFlag = MaybeUserNone -- ^no --user OR --global flag. - | MaybeUserUser -- ^--user flag - | MaybeUserGlobal -- ^--global flag - --- |A 'MaybeUserFlag' overrides the default --user setting -userOverride :: MaybeUserFlag -> Bool -> Bool -MaybeUserUser `userOverride` _ = True -MaybeUserGlobal `userOverride` _ = False -_ `userOverride` r = r - --- | Flags to @install@: (user package, verbose) -data InstallFlags = InstallFlags {installUserFlags::MaybeUserFlag - ,installVerbose :: Int} - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = InstallFlags{ installUserFlags=MaybeUserNone, - installVerbose=0 } - --- | Flags to @sdist@: (snapshot, verbose) -data SDistFlags = SDistFlags {sDistSnapshot::Bool - ,sDistVerbose:: Int} - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbose) -data RegisterFlags = RegisterFlags {regUser::MaybeUserFlag - ,regGenScript::Bool - ,regInPlace::Bool - ,regWithHcPkg::Maybe FilePath - ,regVerbose::Int} - - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = RegisterFlags { regUser=MaybeUserNone, - regGenScript=False, - regInPlace=False, - regWithHcPkg=Nothing, - regVerbose=0 } - -data HaddockFlags = HaddockFlags {haddockHoogle :: Bool - ,haddockVerbose :: Int} - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = HaddockFlags {haddockHoogle = False, haddockVerbose = 0} - --- Following only have verbose flags, but for consistency and --- extensibility we make them into a type. -data BuildFlags = BuildFlags {buildVerbose :: Int} -data CleanFlags = CleanFlags {cleanVerbose :: Int} -data PFEFlags = PFEFlags {pfeVerbose :: Int} - --- |Most of these flags are for Configure, but InstPrefix is for Copy. -data Flag a = GhcFlag | NhcFlag | HugsFlag | JhcFlag - | WithCompiler FilePath | WithHcPkg FilePath - | WithHappy FilePath | WithAlex FilePath - | WithHsc2hs FilePath | WithC2hs FilePath | WithCpphs FilePath - | WithGreencard FilePath - | WithVanillaLib | WithoutVanillaLib - | WithProfLib | WithoutProfLib - | WithProfExe | WithoutProfExe - | WithGHCiLib | WithoutGHCiLib - | WithSplitObjs | WithoutSplitObjs - - | Prefix FilePath - | BinDir FilePath - | LibDir FilePath - | LibSubDir FilePath - | LibExecDir FilePath - | DataDir FilePath - | DataSubDir FilePath - - | ProgramArgs String String -- program name, arguments - | WithProgram String FilePath -- program name, location - - -- For install, register, and unregister: - | UserFlag | GlobalFlag - -- for register & unregister - | GenScriptFlag - | InPlaceFlag - -- For copy: - | InstPrefix FilePath - | DestDir FilePath - -- For sdist: - | Snapshot - -- For haddock: - | HaddockHoogle - -- For everyone: - | HelpFlag - | Verbose Int --- | Version? - | Lift a - deriving (Show, Eq) - - --- ------------------------------------------------------------ --- * Mostly parsing functions --- ------------------------------------------------------------ - -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 - --- | 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 - 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 verboseFlag "n") "Control verbosity (n is 0--5, normal verbosity level is 1, -v alone is equivalent to -v3)" - where - verboseFlag mb_s = Verbose (maybe 3 read mb_s) - -cmd_with_hc_pkg :: OptDescr (Flag a) -cmd_with_hc_pkg = Option "" ["with-hc-pkg"] (reqPathArg WithHcPkg) - "give the path to the package tool" - --- 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 :: [OptDescr (Flag a)], - cmdAction :: Action - } - -commandList :: ProgramConfiguration -> [Cmd a] -commandList progConf = [(configureCmd progConf), buildCmd, cleanCmd, installCmd, - copyCmd, sdistCmd, testCmd, haddockCmd, 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 "Commands:" - 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'." - 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 ++ liftCustomOpts opts)) - putStr (cmdDescription cmd) - -getCmdOpt :: Cmd a -> [OptDescr a] -> [String] -> ([Flag a], [String], [String]) -getCmdOpt cmd opts s = let (a,_,c,d) = getOpt' Permute (cmdOptions cmd ++ liftCustomOpts opts) s - in (a,c,d) - --- 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 = "", -- This can be a multi-line description - cmdOptions = [cmd_help, cmd_verbose, - Option "g" ["ghc"] (NoArg GhcFlag) "compile with GHC", - Option "n" ["nhc"] (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", - cmd_with_hc_pkg, - 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 "" ["with-happy"] (reqPathArg WithHappy) - "give the path to happy", - Option "" ["with-alex"] (reqPathArg WithAlex) - "give the path to alex", - Option "" ["with-hsc2hs"] (reqPathArg WithHsc2hs) - "give the path to hsc2hs", - Option "" ["with-c2hs"] (reqPathArg WithC2hs) - "give the path to c2hs", - Option "" ["with-cpphs"] (reqPathArg WithCpphs) - "give the path to cpphs", - Option "" ["with-greencard"] (reqPathArg WithGreencard) - "give the path to greencard", - 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-executable-profiling"] (NoArg WithProfExe) - "Enable executable profiling", - Option "" ["disable-executable-profiling"] (NoArg WithoutProfExe) - "Disable executable profiling", - 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 "" ["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" - ] -{- - FIX: Instead of using ++ here, we might add extra arguments. That - way, we can condense the help out put to something like - --with-{haddock,happy,alex,etc} - - FIX: shouldn't use default. Look in hooks?. --} - ++ (withProgramOptions progConf) - ++ (programArgsOptions progConf), - cmdAction = ConfigCmd (emptyConfigFlags progConf) - } - -programArgsOptions :: ProgramConfiguration -> [OptDescr (Flag a)] -programArgsOptions (ProgramConfiguration conf) = map f (keys conf) - where f name = Option "" [name ++ "-args"] (reqPathArg (ProgramArgs name)) - ("give the args to " ++ name) - -withProgramOptions :: ProgramConfiguration -> [OptDescr (Flag a)] -withProgramOptions (ProgramConfiguration conf) = map f (keys conf) - where f name = Option "" ["with-" ++ name] (reqPathArg (WithProgram name)) - ("give the path to " ++ name) - -reqPathArg :: (FilePath -> a) -> ArgDescr a -reqPathArg constr = ReqArg (constr . platformPath) "PATH" - -reqDirArg :: (FilePath -> a) -> ArgDescr a -reqDirArg constr = ReqArg (constr . platformPath) "DIR" - -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 (WithHappy path) = t { configHappy = Just path } - updateCfg t (WithAlex path) = t { configAlex = Just path } - updateCfg t (WithHsc2hs path) = t { configHsc2hs = Just path } - updateCfg t (WithC2hs path) = t { configC2hs = Just path } - updateCfg t (WithCpphs path) = t { configCpphs = Just path } - updateCfg t (WithGreencard path) = t { configGreencard= Just path } - updateCfg t (ProgramArgs name args) = t { configPrograms = (userSpecifyArgs - name - args (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 WithProfExe = t { configProfExe = True } - updateCfg t WithoutProfExe = t { configProfExe = 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 (Verbose n) = t { configVerbose = n } - updateCfg t UserFlag = t { configUser = True } - updateCfg t GlobalFlag = t { configUser = False } - updateCfg t WithSplitObjs = t { configSplitObjs = True } - updateCfg t WithoutSplitObjs = t { configSplitObjs = False } - updateCfg t (Lift _) = t - updateCfg t _ = error $ "Unexpected flag!" - -buildCmd :: Cmd a -buildCmd = Cmd { - cmdName = "build", - cmdHelp = "Make this package ready for installation.", - cmdDescription = "", -- This can be a multi-line description - cmdOptions = [cmd_help, cmd_verbose], - cmdAction = BuildCmd - } - -parseBuildArgs :: [String] -> [OptDescr a] -> IO (BuildFlags, [a], [String]) -parseBuildArgs = parseNoArgs buildCmd BuildFlags - -haddockCmd :: Cmd a -haddockCmd = Cmd { - cmdName = "haddock", - cmdHelp = "Generate Haddock HTML code from Exposed-Modules.", - cmdDescription = "Requires cpphs and haddock.", - cmdOptions = [cmd_help, cmd_verbose, - Option "" ["hoogle"] (NoArg HaddockHoogle) "Generate a hoogle database"], - cmdAction = HaddockCmd - } - -parseHaddockArgs :: HaddockFlags -> [String] -> [OptDescr a] -> IO (HaddockFlags, [a], [String]) -parseHaddockArgs = parseArgs haddockCmd updateCfg - where updateCfg (HaddockFlags hoogle verbose) fl = case fl of - HaddockHoogle -> HaddockFlags True verbose - Verbose n -> HaddockFlags hoogle 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], - cmdAction = CleanCmd - } - -parseCleanArgs :: [String] -> [OptDescr a] -> IO (CleanFlags, [a], [String]) -parseCleanArgs = parseNoArgs cleanCmd CleanFlags - -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 verbose) fl = case fl of - InstPrefix path -> (CopyFlags (CopyPrefix path) verbose) - DestDir path -> (CopyFlags (CopyTo path) verbose) - 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 verbose) fl = case fl of - InstPrefix _ -> error "--install-prefix is obsolete. Use copy command instead." - UserFlag -> (InstallFlags MaybeUserUser verbose) - GlobalFlag -> (InstallFlags MaybeUserGlobal verbose) - 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 0) - where updateCfg (SDistFlags snapshot verbose) fl = case fl of - Snapshot -> (SDistFlags True verbose) - 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 (Int, [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 performing the register command, generate a script to register later", - cmd_with_hc_pkg - ], - cmdAction = RegisterCmd - } - -parseRegisterArgs :: RegisterFlags -> [String] -> [OptDescr a] -> - IO (RegisterFlags, [a], [String]) -parseRegisterArgs = parseArgs registerCmd updateCfg - where updateCfg reg fl = case fl of - UserFlag -> reg { regUser=MaybeUserUser } - GlobalFlag -> reg { regUser=MaybeUserGlobal } - Verbose n -> reg { regVerbose=n } - GenScriptFlag -> reg { regGenScript=True } - InPlaceFlag -> reg { regInPlace=True } - WithHcPkg f -> reg { regWithHcPkg=Just f } - _ -> 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 = parseRegisterArgs - --- |Helper function for commands with no arguments except for verbose --- and help. - -parseNoArgs :: (Cmd a) - -> (Int -> b) -- Constructor to make this type. - -> [String] -> [OptDescr a]-> IO (b, [a], [String]) -parseNoArgs cmd c = parseArgs cmd updateCfg (c 0) - 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 ] - -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), ("nhc", NHC), ("hugs", Hugs)] --- (flags, commands', unkFlags, ers) --- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc", "--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.Setup +{-# DEPRECATED "Use module Distribution.Simple.Setup instead" #-} + (module Distribution.Simple.Setup) where +import Distribution.Simple.Setup diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -51,13 +51,14 @@ module Distribution.Package, module Distribution.Version, module Distribution.License, - module Distribution.Compiler, + module Distribution.Simple.Compiler, module Language.Haskell.Extension, -- * Simple interface defaultMain, defaultMainNoRead, defaultMainArgs, -- * Customization UserHooks(..), Args, - defaultMainWithHooks, defaultUserHooks, emptyUserHooks, + defaultMainWithHooks, defaultMainWithHooksArgs, + simpleUserHooks, defaultUserHooks, emptyUserHooks, defaultHookedPackageDesc #ifdef DEBUG ,simpleHunitTests @@ -65,57 +66,51 @@ ) where -- local -import Distribution.Compiler +import Distribution.Simple.Compiler import Distribution.Package --must not specify imports, since we're exporting moule. import Distribution.PackageDescription -import Distribution.Program(lookupProgram, Program(..), ProgramConfiguration(..), - haddockProgram, rawSystemProgram, defaultProgramConfiguration, - pfesetupProgram, updateProgram, rawSystemProgramConf) -import Distribution.PreProcess (knownSuffixHandlers, ppSuffixes, ppCpp', - ppUnlit, removePreprocessedPackage, +import Distribution.Simple.Program(Program(..), ProgramConfiguration, + defaultProgramConfiguration, addKnownProgram, + pfesetupProgram, rawSystemProgramConf) +import Distribution.Simple.PreProcess (knownSuffixHandlers, + removePreprocessedPackage, preprocessSources, PPSuffixHandler) -import Distribution.Setup +import Distribution.Simple.Setup -import Distribution.Simple.Build ( build ) +import Distribution.Simple.Build ( build, makefile ) import Distribution.Simple.SrcDist ( sdist ) import Distribution.Simple.Register ( register, unregister, - writeInstalledConfig, installedPkgConfigFile, - regScriptLocation, unregScriptLocation + writeInstalledConfig, + removeRegScripts ) import Distribution.Simple.Configure(getPersistBuildConfig, maybeGetPersistBuildConfig, - findProgram, configure, writePersistBuildConfig, - localBuildInfoFile) + configure, writePersistBuildConfig) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Install(install) -import Distribution.Simple.Utils (die, currentDir, rawSystemVerbose, - defaultPackageDesc, defaultHookedPackageDesc, - moduleToFilePath, findFile, - distPref, srcPref, haddockPref) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), distPref, srcPref) +import Distribution.Simple.Install (install) +import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.Simple.Utils (die, currentDir, moduleToFilePath, + defaultPackageDesc, defaultHookedPackageDesc) -#if mingw32_HOST_OS || mingw32_TARGET_OS -import Distribution.Simple.Utils (rawSystemPath) -#endif +import Distribution.Simple.Utils (rawSystemPathExit, notice, info) +import Distribution.Verbosity import Language.Haskell.Extension -- Base import System.Environment(getArgs) -import System.Exit(ExitCode(..), exitWith) import System.Directory(removeFile, doesFileExist, doesDirectoryExist) import Distribution.License -import Control.Monad(when, unless) -import Data.List ( intersperse, unionBy ) -import Data.Maybe ( isJust, fromJust ) +import Control.Monad (when, unless) +import Data.List (intersperse, unionBy) import System.IO.Error (try) import Distribution.GetOpt -import Distribution.Compat.Directory(createDirectoryIfMissing,removeDirectoryRecursive, copyFile) -import Distribution.Compat.FilePath(joinFileName, joinPaths, joinFileExt, - splitFileName, splitFileExt, changeFileExt) +import Distribution.Compat.Directory(removeDirectoryRecursive) +import System.FilePath(()) #ifdef DEBUG -import HUnit (Test) +import Test.HUnit (Test) import Distribution.Version hiding (hunitTests) #else import Distribution.Version @@ -130,7 +125,7 @@ -- to specify additional preprocessors. data UserHooks = UserHooks { - runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ExitCode, -- ^Used for @.\/setup test@ + 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'. @@ -140,347 +135,314 @@ -- |Hook to run before configure command preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during configure. - confHook :: PackageDescription -> ConfigFlags -> IO LocalBuildInfo, + confHook :: ( Either GenericPackageDescription PackageDescription + , HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo, -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode, + 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 get different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> BuildFlags -> IO (), + -- |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 ExitCode, + 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 -> Maybe UserHooks -> CleanFlags -> IO (), + 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 ExitCode, + 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 -> Maybe UserHooks -> CopyFlags -> IO (), + copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode, + 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 -> Maybe UserHooks -> InstallFlags -> IO (), + 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 ExitCode, + 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 -> Maybe UserHooks -> SDistFlags -> IO (), + 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 ExitCode, + 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 -> Maybe UserHooks -> RegisterFlags -> IO (), + regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode, + 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 -> Maybe UserHooks -> RegisterFlags -> IO (), + unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode, + 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, - -- |Hook to run after haddock command. Second arg indicates verbosity level. -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> HaddockFlags -> IO (), - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode, + haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), + -- |Hook to run after haddock command. Second arg indicates verbosity level. + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |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 -> Maybe UserHooks -> PFEFlags -> IO (), + pfeHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> PFEFlags -> IO (), -- |Hook to run after pfe command. Second arg indicates verbosity level. - postPFE :: Args -> PFEFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode + postPFE :: Args -> PFEFlags -> PackageDescription -> LocalBuildInfo -> IO () } --- |A simple implementation of @main@ for a Cabal setup script. +-- | 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 = getArgs >>=defaultMainArgs +defaultMain = defaultMain__ Nothing Nothing Nothing +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. defaultMainArgs :: [String] -> IO () -defaultMainArgs args = do - (action, args) <- parseGlobalArgs (allPrograms Nothing) args - pkg_descr_file <- defaultPackageDesc - pkg_descr <- readPackageDescription pkg_descr_file - defaultMainWorker pkg_descr action args Nothing - return () +defaultMainArgs args = defaultMain__ (Just args) Nothing Nothing -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () -defaultMainWithHooks hooks - = do args <- getArgs - (action, args) <- parseGlobalArgs (allPrograms (Just hooks)) args - maybeDesc <- readDesc hooks - pkg_descr <- maybe (defaultPackageDesc >>= readPackageDescription) - return maybeDesc - defaultMainWorker pkg_descr action args (Just hooks) - return () +defaultMainWithHooks hooks = defaultMain__ Nothing (Just hooks) Nothing --- |Like 'defaultMain', but accepts the package description as input +-- | 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 + +-- | Like 'defaultMain', but accepts the package description as input -- rather than using IO to read it. defaultMainNoRead :: PackageDescription -> IO () -defaultMainNoRead pkg_descr - = do args <- getArgs - (action, args) <- parseGlobalArgs (allPrograms Nothing) args - defaultMainWorker pkg_descr action args Nothing - return () +defaultMainNoRead pkg_descr = defaultMain__ Nothing Nothing (Just pkg_descr) --- |Combine the programs in the given hooks with the programs built +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 + +-- | Combine the programs in the given hooks with the programs built -- into cabal. -allPrograms :: Maybe UserHooks +allPrograms :: UserHooks -> ProgramConfiguration -- combine defaults w/ user programs -allPrograms Nothing = defaultProgramConfiguration -allPrograms (Just h) = foldl (\pConf p -> updateProgram (Just p) pConf) - defaultProgramConfiguration - (hookedPrograms h) +allPrograms h = foldl (flip addKnownProgram) + defaultProgramConfiguration + (hookedPrograms h) --- |Combine the preprocessors in the given hooks with the +-- | Combine the preprocessors in the given hooks with the -- preprocessors built into cabal. -allSuffixHandlers :: Maybe UserHooks +allSuffixHandlers :: UserHooks -> [PPSuffixHandler] allSuffixHandlers hooks - = maybe knownSuffixHandlers - (\h -> overridesPP (hookedPreProcessors h) knownSuffixHandlers) - hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers where overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) --- |Helper function for /defaultMain/ and /defaultMainNoRead/ -defaultMainWorker :: PackageDescription +-- | Helper function for /defaultMain/ +defaultMainWorker :: (Maybe PackageDescription) -> Action - -> [String] -- ^args1 - -> Maybe UserHooks - -> IO ExitCode -defaultMainWorker pkg_descr_in action args hooks + -> [String] + -> UserHooks + -> ProgramConfiguration + -> IO () +defaultMainWorker mdescr action all_args hooks prog_conf = do case action of ConfigCmd flags -> do - (flags, optFns, args) <- - parseConfigureArgs (allPrograms hooks) flags args [buildDirOpt] - pkg_descr <- hookOrInArgs preConf args flags - (warns, ers) <- sanityCheckPackage pkg_descr - errorOut warns ers + (flags', optFns, args) <- + parseConfigureArgs prog_conf flags all_args [scratchDirOpt] + pbi <- preConf hooks args flags' - let c = maybe (confHook defaultUserHooks) confHook hooks - localbuildinfo <- c pkg_descr flags - writePersistBuildConfig (foldr id localbuildinfo optFns) - postHook postConf args flags pkg_descr localbuildinfo + pkg_descr0 <- maybe (confPkgDescr flags') (return . Right) mdescr - BuildCmd -> do - (flags, _, args) <- parseBuildArgs args [] - pkg_descr <- hookOrInArgs preBuild args flags - localbuildinfo <- getPersistBuildConfig + -- get_pkg_descr (configVerbose flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) - cmdHook buildHook pkg_descr localbuildinfo flags - postHook postBuild args flags pkg_descr localbuildinfo + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbose flags') warns ers - HaddockCmd -> do - (verbose, _, args) <- parseHaddockArgs emptyHaddockFlags args [] - pkg_descr <- hookOrInArgs preHaddock args verbose - localbuildinfo <- getPersistBuildConfig + localbuildinfo <- confHook hooks epkg_descr flags' - cmdHook haddockHook pkg_descr localbuildinfo verbose - postHook postHaddock args verbose pkg_descr localbuildinfo + writePersistBuildConfig (foldr id localbuildinfo optFns) + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + where + confPkgDescr :: ConfigFlags -> IO (Either GenericPackageDescription + PackageDescription) + confPkgDescr cfgflags = do + mdescr' <- readDesc hooks + case mdescr' of + Just descr -> return $ Right descr + Nothing -> do + pdfile <- defaultPackageDesc (configVerbose cfgflags) + ppd <- readPackageDescription (configVerbose cfgflags) pdfile + return (Left ppd) - ProgramaticaCmd -> do - (verbose, _, args) <- parseProgramaticaArgs args [] - pkg_descr <- hookOrInArgs prePFE args verbose - localbuildinfo <- getPersistBuildConfig + BuildCmd -> do + lbi <- getPersistBuildConfig + res@(flags, _, _) <- + parseBuildArgs prog_conf + (emptyBuildFlags (withPrograms lbi)) all_args [] + command (\_ _ -> return res) buildVerbose + preBuild buildHook postBuild + (return lbi { withPrograms = buildPrograms flags }) - cmdHook pfeHook pkg_descr localbuildinfo verbose - postHook postPFE args verbose pkg_descr localbuildinfo + MakefileCmd -> + command (parseMakefileArgs emptyMakefileFlags) makefileVerbose + preMakefile makefileHook postMakefile + getPersistBuildConfig + HscolourCmd -> + command (parseHscolourArgs emptyHscolourFlags) hscolourVerbose + preHscolour hscolourHook postHscolour + getPersistBuildConfig + + HaddockCmd -> + command (parseHaddockArgs emptyHaddockFlags) haddockVerbose + preHaddock haddockHook postHaddock + getPersistBuildConfig + + ProgramaticaCmd -> do + command parseProgramaticaArgs pfeVerbose + prePFE pfeHook postPFE + getPersistBuildConfig + CleanCmd -> do - (verbose,_, args) <- parseCleanArgs args [] - pkg_descr <- hookOrInArgs preClean args verbose - maybeLocalbuildinfo <- maybeGetPersistBuildConfig + (flags, _, args) <- parseCleanArgs emptyCleanFlags all_args [] - cmdHook cleanHook pkg_descr maybeLocalbuildinfo verbose - postHook postClean args verbose pkg_descr maybeLocalbuildinfo + pbi <- preClean hooks args flags - CopyCmd mprefix -> do - (flags, _, args) <- parseCopyArgs (CopyFlags mprefix 0) args [] - pkg_descr <- hookOrInArgs preCopy args flags - localbuildinfo <- getPersistBuildConfig + mlbi <- maybeGetPersistBuildConfig + pdfile <- defaultPackageDesc (cleanVerbose flags) + ppd <- readPackageDescription (cleanVerbose flags) pdfile + let pkg_descr0 = flattenPackageDescription ppd + let pkg_descr = updatePackageDescription pbi pkg_descr0 - cmdHook copyHook pkg_descr localbuildinfo flags - postHook postCopy args flags pkg_descr localbuildinfo + cleanHook hooks pkg_descr mlbi hooks flags + postClean hooks args flags pkg_descr mlbi - InstallCmd -> do - (flags, _, args) <- parseInstallArgs emptyInstallFlags args [] - pkg_descr <- hookOrInArgs preInst args flags - localbuildinfo <- getPersistBuildConfig + CopyCmd mprefix -> do + command (parseCopyArgs (emptyCopyFlags mprefix)) copyVerbose + preCopy copyHook postCopy + getPersistBuildConfig - cmdHook instHook pkg_descr localbuildinfo flags - postHook postInst args flags pkg_descr localbuildinfo + InstallCmd -> do + command (parseInstallArgs emptyInstallFlags) installVerbose + preInst instHook postInst + getPersistBuildConfig SDistCmd -> do - (flags,_, args) <- parseSDistArgs args [] - pkg_descr <- hookOrInArgs preSDist args flags - maybeLocalbuildinfo <- maybeGetPersistBuildConfig + (flags, _, args) <- parseSDistArgs all_args [] - cmdHook sDistHook pkg_descr maybeLocalbuildinfo flags - postHook postSDist args flags pkg_descr maybeLocalbuildinfo + pbi <- preSDist hooks args flags + mlbi <- maybeGetPersistBuildConfig + pdfile <- defaultPackageDesc (sDistVerbose flags) + ppd <- readPackageDescription (sDistVerbose flags) 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 + TestCmd -> do - (verbose,_, args) <- parseTestArgs args [] - case hooks of - Nothing -> return ExitSuccess - Just h -> do localbuildinfo <- getPersistBuildConfig - out <- (runTests h) args False pkg_descr_in localbuildinfo - when (isFailure out) (exitWith out) - return out + (_verbosity,_, args) <- parseTestArgs all_args [] + localbuildinfo <- getPersistBuildConfig + let pkg_descr = localPkgDescr localbuildinfo + runTests hooks args False pkg_descr localbuildinfo RegisterCmd -> do - (flags, _, args) <- parseRegisterArgs emptyRegisterFlags args [] - pkg_descr <- hookOrInArgs preReg args flags - localbuildinfo <- getPersistBuildConfig - - cmdHook regHook pkg_descr localbuildinfo flags - postHook postReg args flags pkg_descr localbuildinfo + command (parseRegisterArgs emptyRegisterFlags) regVerbose + preReg regHook postReg + getPersistBuildConfig UnregisterCmd -> do - (flags,_, args) <- parseUnregisterArgs emptyRegisterFlags args [] - pkg_descr <- hookOrInArgs preUnreg args flags - localbuildinfo <- getPersistBuildConfig - - cmdHook unregHook pkg_descr localbuildinfo flags - postHook postUnreg args flags pkg_descr localbuildinfo + command (parseUnregisterArgs emptyRegisterFlags) regVerbose + preUnreg unregHook postUnreg + getPersistBuildConfig - HelpCmd -> return ExitSuccess -- this is handled elsewhere + HelpCmd -> return () -- this is handled elsewhere where - hookOrInArgs :: (UserHooks -> ([String] -> b -> IO HookedBuildInfo)) - -> [String] - -> b - -> IO PackageDescription - hookOrInArgs f a i - = case hooks of - Nothing -> no_extra_flags a >> return pkg_descr_in - Just h -> do pbi <- f h a i - return (updatePackageDescription pbi pkg_descr_in) - cmdHook f desc lbi = (maybe (f defaultUserHooks) f hooks) desc lbi hooks - postHook f args flags pkg_descr localbuildinfo - = case hooks of - Nothing -> return ExitSuccess - Just h -> f h args flags pkg_descr localbuildinfo - - isFailure :: ExitCode -> Bool - isFailure (ExitFailure _) = True - isFailure _ = False - --- (filter (\x -> notElem x overriders) overridden) ++ overriders + 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 -getModulePaths :: BuildInfo -> [String] -> IO [FilePath] -getModulePaths bi = +--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 (hsSourceDirs bi)) ["hs", "lhs"]) - -haddock :: PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> HaddockFlags -> IO () -haddock pkg_descr lbi hooks (HaddockFlags hoogle verbose) = do - let pps = allSuffixHandlers hooks - confHaddock <- do let programConf = withPrograms lbi - let haddockName = programName haddockProgram - mHaddock <- lookupProgram haddockName programConf - maybe (die "haddock command not found") return mHaddock - - let tmpDir = joinPaths (buildDir lbi) "tmp" - createDirectoryIfMissing True tmpDir - createDirectoryIfMissing True haddockPref - preprocessSources pkg_descr lbi verbose pps - - setupMessage "Running Haddock for" pkg_descr - - let replaceLitExts = map (joinFileName tmpDir . flip changeFileExt "hs") - let mockAll bi = mapM_ (mockPP ["-D__HADDOCK__"] pkg_descr bi lbi tmpDir verbose) - let showPkg = showPackageId (package pkg_descr) - let showDepPkgs = map showPackageId (packageDeps lbi) - let outputFlag = if hoogle then "--hoogle" else "--html" - - withLib pkg_descr () $ \lib -> do - let bi = libBuildInfo lib - inFiles <- getModulePaths bi (exposedModules lib ++ otherModules bi) - mockAll bi inFiles - let prologName = showPkg ++ "-haddock-prolog.txt" - writeFile prologName (description pkg_descr ++ "\n") - let outFiles = replaceLitExts inFiles - let haddockFile = joinFileName haddockPref (haddockName pkg_descr) - -- FIX: replace w/ rawSystemProgramConf? - rawSystemProgram verbose confHaddock - ([outputFlag, - "--odir=" ++ haddockPref, - "--title=" ++ showPkg ++ ": " ++ synopsis pkg_descr, - "--package=" ++ showPkg, - "--dump-interface=" ++ haddockFile, - "--prologue=" ++ prologName] - ++ map ("--use-package=" ++) showDepPkgs - ++ programArgs confHaddock - ++ (if verbose > 4 then ["--verbose"] else []) - ++ outFiles - ++ map ("--hide=" ++) (otherModules bi) - ) - removeFile prologName - withExe pkg_descr $ \exe -> do - let bi = buildInfo exe - exeTargetDir = haddockPref `joinFileName` exeName exe - createDirectoryIfMissing True exeTargetDir - inFiles' <- getModulePaths bi (otherModules bi) - srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) - let inFiles = srcMainPath : inFiles' - mockAll bi inFiles - let outFiles = replaceLitExts inFiles - rawSystemProgram verbose confHaddock - ([outputFlag, - "--odir=" ++ exeTargetDir, - "--title=" ++ exeName exe] - ++ map ("--use-package=" ++) (showPkg:showDepPkgs) - ++ programArgs confHaddock - ++ (if verbose > 4 then ["--verbose"] else []) - ++ outFiles - ) + mapM (flip (moduleToFilePath (buildDir lbi : hsSourceDirs bi)) ["hs", "lhs"]) - removeDirectoryRecursive tmpDir - where - mockPP inputArgs pkg_descr bi lbi pref verbose file - = do let (filePref, fileName) = splitFileName file - let targetDir = joinPaths pref filePref - let targetFile = joinFileName targetDir fileName - let (targetFileNoext, targetFileExt) = splitFileExt targetFile - createDirectoryIfMissing True targetDir - if (needsCpp pkg_descr) - then ppCpp' inputArgs bi lbi file targetFile verbose - else copyFile file targetFile >> return ExitSuccess - when (targetFileExt == "lhs") $ do - ppUnlit targetFile (joinFileExt targetFileNoext "hs") verbose - return () - needsCpp :: PackageDescription -> Bool - needsCpp p = - hasLibs p && - any (== CPP) (extensions $ libBuildInfo $ fromJust $ library p) +-- -------------------------------------------------------------------------- +-- Programmatica support -pfe :: PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> PFEFlags -> IO () -pfe pkg_descr _lbi hooks (PFEFlags verbose) = do +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" @@ -488,51 +450,48 @@ lbi <- getPersistBuildConfig let bi = libBuildInfo lib let mods = exposedModules lib ++ otherModules (libBuildInfo lib) - preprocessSources pkg_descr lbi verbose pps - inFiles <- getModulePaths bi mods - rawSystemProgramConf verbose (programName pfesetupProgram) (withPrograms lbi) - ("noplogic":"cpp": (if verbose > 4 then ["-v"] else []) - ++ inFiles) - return () + 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) -clean :: PackageDescription -> Maybe LocalBuildInfo -> Maybe UserHooks -> CleanFlags -> IO () -clean pkg_descr maybeLbi hooks (CleanFlags verbose) = do - let pps = allSuffixHandlers hooks - putStrLn "cleaning..." - try $ removeDirectoryRecursive (joinPaths distPref "doc") - try $ removeFile installedPkgConfigFile - try $ removeFile localBuildInfoFile - try $ removeFile regScriptLocation - try $ removeFile unregScriptLocation - removePreprocessedPackage pkg_descr currentDir (ppSuffixes pps) + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> CleanFlags -> IO () +clean pkg_descr maybeLbi _ (CleanFlags saveConfigure verbosity) = do + notice verbosity "cleaning..." + + maybeConfig <- if saveConfigure then maybeGetPersistBuildConfig + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + try $ removeDirectoryRecursive distPref + + -- these live in the top level dir so must be removed separately + removeRegScripts + + -- Any extra files the user wants to remove mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) - when (isJust maybeLbi) $ do - let lbi = fromJust maybeLbi - try $ removeDirectoryRecursive (buildDir lbi) + -- 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 - GHC -> cleanGHCExtras lbi JHC -> cleanJHCExtras lbi _ -> return () + + -- If the user wanted to save the config, write it back + maybe (return ()) writePersistBuildConfig maybeConfig + where - cleanGHCExtras lbi = do - -- remove source stubs for library - withLib pkg_descr () $ \ Library{libBuildInfo=bi} -> - removeGHCModuleStubs bi (libModules pkg_descr) - -- remove source stubs for executables - withExe pkg_descr $ \ Executable{modulePath=exeSrcName - ,buildInfo=bi} -> do - removeGHCModuleStubs bi (exeModules pkg_descr) - let (startN, _) = splitFileExt exeSrcName - try $ removeFile (startN ++ "_stub.h") - try $ removeFile (startN ++ "_stub.c") - removeGHCModuleStubs :: BuildInfo -> [String] -> IO () - removeGHCModuleStubs (BuildInfo{hsSourceDirs=dirs}) mods = do - s <- mapM (\x -> moduleToFilePath dirs (x ++"_stub") ["h", "c"]) mods - mapM_ removeFile (concat s) -- JHC FIXME remove exe-sources cleanJHCExtras lbi = do - try $ removeFile (buildDir lbi `joinFileName` "jhc-pkg.conf") + try $ removeFile (buildDir lbi "jhc-pkg.conf") removePreprocessedPackage pkg_descr currentDir ["ho"] removeFileOrDirectory :: FilePath -> IO () removeFileOrDirectory fname = do @@ -542,61 +501,89 @@ else if isFile then removeFile fname else return () +-- -------------------------------------------------------------------------- +-- Default hooks + no_extra_flags :: [String] -> IO () no_extra_flags [] = return () -no_extra_flags extra_flags = - die ("Unrecognised flags: " ++ concat (intersperse "," extra_flags)) +no_extra_flags extra_flags = + die $ concat + $ intersperse "\n" ("Unrecognised flags:" : map (' ' :) extra_flags) -buildDirOpt :: OptDescr (LocalBuildInfo -> LocalBuildInfo) -buildDirOpt = Option "b" ["scratchdir"] (reqDirArg setBuildDir) - "directory to receive the built package [dist/build]" - where setBuildDir dir lbi = lbi { buildDir = dir } +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 = res, + 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 = res, + postConf = ru, preBuild = rn, buildHook = ru, - postBuild = res, + postBuild = ru, + preMakefile = rn, + makefileHook = ru, + postMakefile = ru, preClean = rn, cleanHook = ru, - postClean = res, + postClean = ru, preCopy = rn, copyHook = ru, - postCopy = res, + postCopy = ru, preInst = rn, instHook = ru, - postInst = res, + postInst = ru, preSDist = rn, sDistHook = ru, - postSDist = res, + postSDist = ru, preReg = rn, regHook = ru, - postReg = res, + postReg = ru, preUnreg = rn, unregHook = ru, - postUnreg = res, + postUnreg = ru, prePFE = rn, pfeHook = ru, - postPFE = res, - preHaddock = rn, - haddockHook = ru, - postHaddock = res + postPFE = ru, + preHscolour = rn, + hscolourHook = ru, + postHscolour = ru, + preHaddock = rn, + haddockHook = ru, + postHaddock = ru } - where rn _ _ = return emptyHookedBuildInfo - res _ _ _ _ = return ExitSuccess + where rn args _ = no_extra_flags args >> return emptyHookedBuildInfo ru _ _ _ _ = return () --- |Basic default 'UserHooks': +-- | Hooks that correspond to a plain instantiation of the +-- "simple" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks { + confHook = configure, + buildHook = defaultBuildHook, + 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, + regHook = defaultRegHook, + unregHook = \p l _ f -> unregister p l f + } + +-- | Basic autoconf 'UserHooks': -- -- * on non-Windows systems, 'postConf' runs @.\/configure@, if present. -- @@ -610,78 +597,88 @@ -- FIXME: do something sensible for windows, or do nothing in postConf. defaultUserHooks :: UserHooks -defaultUserHooks - = emptyUserHooks +defaultUserHooks = autoconfUserHooks + +autoconfUserHooks :: UserHooks +autoconfUserHooks + = simpleUserHooks { postConf = defaultPostConf, - confHook = configure, preBuild = readHook buildVerbose, - buildHook = defaultBuildHook, + preMakefile = readHook makefileVerbose, preClean = readHook cleanVerbose, preCopy = readHook copyVerbose, - copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params preInst = readHook installVerbose, - instHook = defaultInstallHook, - sDistHook = \p _ h f -> sdist p f srcPref distPref (allSuffixHandlers h), - pfeHook = pfe, - cleanHook = clean, + preHscolour = readHook hscolourVerbose, preHaddock = readHook haddockVerbose, - haddockHook = haddock, preReg = readHook regVerbose, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f, preUnreg = readHook regVerbose } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode - defaultPostConf args flags pkg_descr lbi - = do let verbose = configVerbose flags - args' = configureArgs flags ++ args + where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + defaultPostConf args flags _ _ + = do let verbosity = configVerbose flags + no_extra_flags args confExists <- doesFileExist "configure" - if confExists then -#if mingw32_HOST_OS || mingw32_TARGET_OS - -- FIXME: hack for script files under MinGW - -- This assumes sh (check for #! line?) - rawSystemPath verbose "sh" ("configure" : args') -#else - -- FIXME: should we really be discarding the exit code? - rawSystemVerbose verbose "./configure" args' -#endif - else do - no_extra_flags args - return ExitSuccess + when confExists $ + rawSystemPathExit verbosity "sh" $ + "configure" : configureArgs flags - readHook :: (a -> Int) -> Args -> a -> IO HookedBuildInfo - readHook verbose a flags = do + readHook :: (a -> Verbosity) -> Args -> a -> IO HookedBuildInfo + readHook get_verbosity a flags = do no_extra_flags a maybe_infoFile <- defaultHookedPackageDesc case maybe_infoFile of Nothing -> return emptyHookedBuildInfo Just infoFile -> do - when (verbose flags > 0) $ - putStrLn $ "Reading parameters from " ++ infoFile - readHookedBuildInfo infoFile + let verbosity = get_verbosity flags + info verbosity $ "Reading parameters from " ++ infoFile + readHookedBuildInfo verbosity infoFile defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> Maybe UserHooks ->InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ (InstallFlags uInstFlag verbose) = do - install pkg_descr localbuildinfo (CopyFlags NoCopyDest verbose) + -> UserHooks -> InstallFlags -> IO () +defaultInstallHook pkg_descr localbuildinfo _ (InstallFlags uInstFlag verbosity) = do + install pkg_descr localbuildinfo (CopyFlags NoCopyDest verbosity) when (hasLibs pkg_descr) $ - register pkg_descr localbuildinfo - emptyRegisterFlags{ regUser=uInstFlag, regVerbose=verbose } + register pkg_descr localbuildinfo + emptyRegisterFlags{ regPackageDB=uInstFlag, regVerbose=verbosity } defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> Maybe UserHooks -> BuildFlags -> IO () + -> UserHooks -> BuildFlags -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags = do build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) when (hasLibs pkg_descr) $ - writeInstalledConfig pkg_descr localbuildinfo False + writeInstalledConfig pkg_descr localbuildinfo False Nothing +defaultMakefileHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> MakefileFlags -> IO () +defaultMakefileHook pkg_descr localbuildinfo hooks flags = do + makefile pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + when (hasLibs pkg_descr) $ + writeInstalledConfig pkg_descr localbuildinfo False Nothing + defaultRegHook :: PackageDescription -> LocalBuildInfo - -> Maybe UserHooks -> RegisterFlags -> IO () + -> UserHooks -> RegisterFlags -> IO () defaultRegHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags - else die "Package contains no library to register" + 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 diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -8,6 +8,8 @@ -- Stability : alpha -- Portability : portable -- +-- Invokes the "Distribution.Compiler"s to build the library and +-- executables in this package. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -41,59 +43,89 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Build ( - build + build, makefile #ifdef DEBUG ,hunitTests #endif ) where -import Distribution.Compiler ( Compiler(..), CompilerFlavor(..) ) +import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..) ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), setupMessage, Executable(..), Library(..), autogenModuleName ) import Distribution.Package ( PackageIdentifier(..), showPackageId ) -import Distribution.Setup (CopyDest(..), BuildFlags(..) ) -import Distribution.PreProcess ( preprocessSources, PPSuffixHandler ) +import Distribution.Simple.Setup ( CopyDest(..), BuildFlags(..), + MakefileFlags(..) ) +import Distribution.Simple.PreProcess ( preprocessSources, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), mkBinDir, mkBinDirRel, - mkLibDir, mkLibDirRel, mkDataDir,mkDataDirRel, - mkLibexecDir, mkLibexecDirRel ) + ( LocalBuildInfo(..), + InstallDirs(..), absoluteInstallDirs, + prefixRelativeInstallDirs ) import Distribution.Simple.Configure ( localBuildInfoFile ) -import Distribution.Simple.Utils( die ) +import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, die ) +import Distribution.System -import Distribution.Compat.Directory - ( createDirectoryIfMissing ) -import Distribution.Compat.FilePath - ( joinFileName, pathSeparator ) +import System.FilePath ( (), pathSeparator ) -import Data.Maybe ( maybeToList, fromJust ) -import Control.Monad ( unless ) -import System.Directory ( getModificationTime, doesFileExist) +import Data.Maybe ( maybeToList, fromJust, isNothing ) +import Control.Monad ( unless, when ) +import System.Directory ( getModificationTime, doesFileExist ) import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.JHC as JHC --- import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.NHC as NHC import qualified Distribution.Simple.Hugs as Hugs -#ifdef mingw32_HOST_OS import Distribution.PackageDescription (hasLibs) -#endif +import Distribution.Verbosity #ifdef DEBUG -import HUnit (Test) +import Test.HUnit (Test) #endif -- ----------------------------------------------------------------------------- --- Build the library +-- |Build the libraries and executables in this package. -build :: PackageDescription - -> LocalBuildInfo - -> BuildFlags - -> [ PPSuffixHandler ] +build :: PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> BuildFlags -- ^Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling -> IO () -build pkg_descr lbi (BuildFlags verbose) suffixes = do +build pkg_descr lbi flags suffixes = do + let verbosity = buildVerbose flags + initialBuildSteps pkg_descr lbi verbosity suffixes + setupMessage verbosity "Building" pkg_descr + case compilerFlavor (compiler lbi) of + GHC -> GHC.build pkg_descr lbi verbosity + JHC -> JHC.build pkg_descr lbi verbosity + Hugs -> Hugs.build pkg_descr lbi verbosity + NHC -> NHC.build pkg_descr lbi verbosity + _ -> die ("Building is not supported with this compiler.") + +makefile :: PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> MakefileFlags -- ^Flags that the user passed to makefile + -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling + -> IO () +makefile pkg_descr lbi flags suffixes = do + let verb = makefileVerbose flags + initialBuildSteps pkg_descr lbi verb suffixes + when (not (hasLibs pkg_descr)) $ + die ("Makefile is only supported for libraries, currently.") + setupMessage verb "Generating Makefile" 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 + -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling + -> IO () +initialBuildSteps pkg_descr lbi verbosity suffixes = do -- check that there's something to build let buildInfos = map libBuildInfo (maybeToList (library pkg_descr)) ++ @@ -102,19 +134,13 @@ let name = showPackageId (package pkg_descr) die ("Package " ++ name ++ " can't be built on this system.") - createDirectoryIfMissing True (buildDir lbi) + createDirectoryIfMissingVerbose verbosity True (buildDir lbi) -- construct and write the Paths_.hs file - createDirectoryIfMissing True (autogenModulesDir lbi) + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) buildPathsModule pkg_descr lbi - preprocessSources pkg_descr lbi verbose suffixes - setupMessage "Building" pkg_descr - case compilerFlavor (compiler lbi) of - GHC -> GHC.build pkg_descr lbi verbose - JHC -> JHC.build pkg_descr lbi verbose - Hugs -> Hugs.build pkg_descr lbi verbose - _ -> die ("Building is not supported with this compiler.") + preprocessSources pkg_descr lbi False verbosity suffixes -- ------------------------------------------------------------ -- * Building Paths_.hs @@ -122,18 +148,19 @@ -- The directory in which we put auto-generated modules autogenModulesDir :: LocalBuildInfo -> String -autogenModulesDir lbi = buildDir lbi `joinFileName` "autogen" +autogenModulesDir lbi = buildDir lbi "autogen" buildPathsModule :: PackageDescription -> LocalBuildInfo -> IO () buildPathsModule pkg_descr lbi = let pragmas - | absolute = "" + | absolute || isHugs = "" | otherwise = "{-# OPTIONS_GHC -fffi #-}\n"++ "{-# LANGUAGE ForeignFunctionInterface #-}\n" foreign_imports | absolute = "" + | isHugs = "import System.Environment\n" | otherwise = "import Foreign\n"++ "import Foreign.C\n"++ @@ -150,11 +177,13 @@ foreign_imports++ "import Data.Version"++ "\n"++ + "\nversion :: Version"++ "\nversion = " ++ show (pkgVersion (package pkg_descr))++ "\n" body | absolute = + "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ "\nbindir = " ++ show flat_bindir ++ "\nlibdir = " ++ show flat_libdir ++ "\ndatadir = " ++ show flat_datadir ++ @@ -169,10 +198,10 @@ "getDataFileName :: FilePath -> IO FilePath\n"++ "getDataFileName name = return (datadir ++ "++path_sep++" ++ name)\n" | otherwise = - "\nprefix = " ++ show (prefix lbi) ++ + "\nprefix = " ++ show flat_prefix ++ "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ - "\n"++ - "\ngetBinDir :: IO FilePath\n"++ + "\n\n"++ + "getBinDir :: IO FilePath\n"++ "getBinDir = getPrefixDirRel bindirrel\n\n"++ "getLibDir :: IO FilePath\n"++ "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ @@ -185,7 +214,9 @@ " dir <- getDataDir\n"++ " return (dir `joinFileName` name)\n"++ "\n"++ - get_prefix_stuff + get_prefix_stuff++ + "\n"++ + filename_stuff in do btime <- getModificationTime localBuildInfoFile exists <- doesFileExist paths_filepath ptime <- if exists @@ -195,32 +226,51 @@ then writeFile paths_filepath (header++body) else return () where - flat_bindir = mkBinDir pkg_descr lbi NoCopyDest - flat_bindirrel = mkBinDirRel pkg_descr lbi NoCopyDest - flat_libdir = mkLibDir pkg_descr lbi NoCopyDest - flat_libdirrel = mkLibDirRel pkg_descr lbi NoCopyDest - flat_datadir = mkDataDir pkg_descr lbi NoCopyDest - flat_datadirrel = mkDataDirRel pkg_descr lbi NoCopyDest - flat_libexecdir = mkLibexecDir pkg_descr lbi NoCopyDest - flat_libexecdirrel = mkLibexecDirRel pkg_descr lbi NoCopyDest + InstallDirs { + prefix = flat_prefix, + bindir = flat_bindir, + libdir = flat_libdir, + datadir = flat_datadir, + libexecdir = flat_libexecdir + } = absoluteInstallDirs pkg_descr lbi NoCopyDest + InstallDirs { + bindir = flat_bindirrel, + libdir = flat_libdirrel, + datadir = flat_datadirrel, + libexecdir = flat_libexecdirrel, + progdir = flat_progdirrel + } = prefixRelativeInstallDirs pkg_descr lbi - mkGetDir dir (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel mkGetDir dir Nothing = "return " ++ show dir -#if mingw32_HOST_OS - absolute = hasLibs pkg_descr || flat_bindirrel == Nothing -#else - absolute = True -#endif + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + supportsRelocatableProgs Hugs = True + supportsRelocatableProgs GHC = case os of + Windows _ -> True + _ -> False + supportsRelocatableProgs _ = False + paths_modulename = autogenModuleName pkg_descr paths_filename = paths_modulename ++ ".hs" - paths_filepath = autogenModulesDir lbi `joinFileName` paths_filename + paths_filepath = autogenModulesDir lbi paths_filename + isHugs = compilerFlavor (compiler lbi) == Hugs + get_prefix_stuff + | isHugs = "progdirrel :: String\n"++ + "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ + get_prefix_hugs + | otherwise = get_prefix_win32 + path_sep = show [pathSeparator] -get_prefix_stuff :: String -get_prefix_stuff = +get_prefix_win32 :: String +get_prefix_win32 = "getPrefixDirRel :: FilePath -> IO FilePath\n"++ "getPrefixDirRel dirRel = do \n"++ " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++ @@ -232,17 +282,27 @@ " else do exePath <- peekCString buf\n"++ " free buf\n"++ " let (bindir,_) = splitFileName exePath\n"++ - " return (prefixFromBinDir bindir bindirrel `joinFileName` dirRel)\n"++ - " where\n"++ - " prefixFromBinDir bindir path\n"++ - " | path' == \".\" = bindir'\n"++ - " | otherwise = prefixFromBinDir bindir' path'\n"++ - " where\n"++ - " (bindir',_) = splitFileName bindir\n"++ - " (path', _) = splitFileName path\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ "\n"++ "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++ - " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n"++ + " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n" + +get_prefix_hugs :: String +get_prefix_hugs = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = do\n"++ + " mainPath <- getProgName\n"++ + " let (progPath,_) = splitFileName mainPath\n"++ + " let (progdir,_) = splitFileName progPath\n"++ + " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" + +filename_stuff :: String +filename_stuff = + "minusFileName :: FilePath -> String -> FilePath\n"++ + "minusFileName dir \"\" = dir\n"++ + "minusFileName dir \".\" = dir\n"++ + "minusFileName dir suffix =\n"++ + " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ "\n"++ "joinFileName :: String -> String -> FilePath\n"++ "joinFileName \"\" fname = fname\n"++ @@ -252,6 +312,7 @@ " | isPathSeparator (last dir) = dir++fname\n"++ " | otherwise = dir++pathSeparator:fname\n"++ "\n"++ + "splitFileName :: FilePath -> (String, String)\n"++ "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ " where\n"++ " (path,drive) = case p of\n"++ @@ -266,11 +327,14 @@ " _ -> path1\n"++ "\n"++ "pathSeparator :: Char\n"++ - "pathSeparator = '\\\\'\n"++ + (case os of + Windows _ -> "pathSeparator = '\\\\'\n" + _ -> "pathSeparator = '/'\n") ++ "\n"++ "isPathSeparator :: Char -> Bool\n"++ - "isPathSeparator ch =\n"++ - " ch == '/' || ch == '\\\\'\n" + (case os of + Windows _ -> "isPathSeparator c = c == '/' || c == '\\\\'\n" + _ -> "isPathSeparator c = c == '/'\n") -- ------------------------------------------------------------ -- * Testing diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Compiler.hs @@ -0,0 +1,127 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Haskell implementations. + +{- 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.Compiler ( + -- * Haskell implementations + module Distribution.Compiler, + Compiler(..), + showCompilerId, compilerVersion, + + -- * Support for package databases + PackageDB(..), + + -- * 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 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)] + } + deriving (Show, Read) + +showCompilerId :: Compiler -> String +showCompilerId = showPackageId . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = pkgVersion . compilerId + +-- ------------------------------------------------------------ +-- * Package databases +-- ------------------------------------------------------------ + +-- |Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isloated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +data PackageDB = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Show, Read) + +-- ------------------------------------------------------------ +-- * Extensions +-- ------------------------------------------------------------ + +-- |For the given compiler, return the flags for the supported extensions. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts + , isNothing $ lookup ext (compilerExtensions comp) ] + +type Flag = String + +-- |For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [Flag] +extensionsToFlags comp exts = + 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 @@ -9,7 +9,7 @@ -- Portability : portable -- -- Explanation: Perform the \"@.\/setup configure@\" action. --- Outputs the @.setup-config@ file. +-- Outputs the @dist\/setup-config@ file. {- All rights reserved. @@ -41,12 +41,12 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.Configure (writePersistBuildConfig, +module Distribution.Simple.Configure (configure, + writePersistBuildConfig, getPersistBuildConfig, maybeGetPersistBuildConfig, - configure, +-- getConfiguredPkgDescr, localBuildInfoFile, - findProgram, getInstalledPackages, configDependency, configCompiler, configCompilerAux, @@ -64,205 +64,272 @@ #endif #endif +import Distribution.Compat.Directory + ( createDirectoryIfMissing ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(..), compilerVersion, showCompilerId + , unsupportedExtensions, PackageDB(..) ) +import Distribution.Package + ( PackageIdentifier(..), showPackageId ) +import Distribution.PackageDescription + ( PackageDescription(..), GenericPackageDescription(..) + , Library(..), Executable(..), BuildInfo(..), finalizePackageDescription + , HookedBuildInfo, sanityCheckPackage, updatePackageDescription + , setupMessage, satisfyDependency, hasLibs, allBuildInfo ) +import Distribution.ParseUtils + ( showDependency ) +import Distribution.Simple.Program + ( Program(..), ProgramLocation(..), ConfiguredProgram(..) + , ProgramConfiguration, configureAllKnownPrograms, knownPrograms + , lookupKnownProgram, requireProgram, pkgConfigProgram + , rawSystemProgramStdoutConf ) +import Distribution.Simple.Setup + ( ConfigFlags(..), CopyDest(..) ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), InstallDirTemplates(..), defaultInstallDirs + , toPathTemplate ) import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Register (removeInstalledConfig) -import Distribution.Setup(ConfigFlags(..), CopyDest(..)) -import Distribution.Compiler(CompilerFlavor(..), Compiler(..), - compilerBinaryName, extensionsToFlags) -import Distribution.Package (PackageIdentifier(..), showPackageId, - parsePackageId) -import Distribution.PackageDescription( - PackageDescription(..), Library(..), - BuildInfo(..), Executable(..), setupMessage ) -import Distribution.Simple.Utils (die, warn, withTempFile,maybeExit) -import Distribution.Version (Version(..), Dependency(..), VersionRange(ThisVersion), - parseVersion, showVersion, withinRange, - showVersionRange) + ( LocalBuildInfo(..), distPref, absoluteInstallDirs + , prefixRelativeInstallDirs ) +import Distribution.Simple.Utils + ( die, warn, info ) +import Distribution.Simple.Register + ( removeInstalledConfig ) +import Distribution.System + ( os, OS(..), Windows(..) ) +import Distribution.Version + ( Version(..), Dependency(..), VersionRange(..), showVersion, readVersion + , showVersionRange, orLaterVersion, withinRange ) +import Distribution.Verbosity + ( Verbosity, lessVerbose ) -import Data.List (intersperse, nub, maximumBy, isPrefixOf) -import Data.Char (isSpace) -import Data.Maybe(fromMaybe) +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.Hugs as Hugs + +import Control.Monad + ( when, unless, foldM ) +import Control.Exception as Exception + ( catch ) +import Data.Char + ( toLower ) +import Data.List + ( intersperse, nub, partition, isPrefixOf ) +import Data.Maybe + ( fromMaybe, isNothing ) import System.Directory -import Distribution.Compat.FilePath (splitFileName, joinFileName, - joinFileExt, exeExtension) -import Distribution.Program(Program(..), ProgramLocation(..), - lookupPrograms, updateProgram) -import System.Cmd ( system ) -import System.Exit ( ExitCode(..) ) -import Control.Monad ( when, unless ) -import Distribution.Compat.ReadP -import Distribution.Compat.Directory (findExecutable) -import Data.Char (isDigit) + ( doesFileExist ) +import System.Environment + ( getProgName ) +import System.Exit + ( ExitCode(..), exitWith ) +import System.FilePath + ( () ) +import qualified System.Info + ( os, arch ) +import System.IO + ( hPutStrLn, stderr ) +import Text.PrettyPrint.HughesPJ + ( comma, punctuate, render, nest, sep ) + import Prelude hiding (catch) -#ifdef mingw32_HOST_OS -import Distribution.PackageDescription (hasLibs) -#endif - #ifdef DEBUG -import HUnit +import Test.HUnit #endif -tryGetPersistBuildConfig :: IO (Either String LocalBuildInfo) -tryGetPersistBuildConfig = do - e <- doesFileExist localBuildInfoFile - let dieMsg = "error reading " ++ localBuildInfoFile ++ "; run \"setup configure\" command?\n" +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 <- readFile localBuildInfoFile + str <- readFile filename case reads str of [(bi,_)] -> return $ Right bi _ -> return $ Left dieMsg +-- internal function +tryGetPersistBuildConfig :: IO (Either String LocalBuildInfo) +tryGetPersistBuildConfig = tryGetConfigStateFile localBuildInfoFile + +-- |Read the 'localBuildInfoFile'. Error if it doesn't exist. getPersistBuildConfig :: IO LocalBuildInfo getPersistBuildConfig = do lbi <- tryGetPersistBuildConfig either die return lbi +-- |Try to read the 'localBuildInfoFile'. maybeGetPersistBuildConfig :: IO (Maybe LocalBuildInfo) maybeGetPersistBuildConfig = do lbi <- tryGetPersistBuildConfig return $ either (const Nothing) Just lbi +-- |After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. writePersistBuildConfig :: LocalBuildInfo -> IO () writePersistBuildConfig lbi = do + createDirectoryIfMissing False distPref writeFile localBuildInfoFile (show lbi) +-- |@dist\/setup-config@ localBuildInfoFile :: FilePath -localBuildInfoFile = "./.setup-config" +localBuildInfoFile = distPref "setup-config" + -- ----------------------------------------------------------------------------- -- * Configuration -- ----------------------------------------------------------------------------- -configure :: PackageDescription -> ConfigFlags -> IO LocalBuildInfo -configure pkg_descr cfg - = do - setupMessage "Configuring" pkg_descr - removeInstalledConfig - let lib = library pkg_descr +-- |Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure :: ( Either GenericPackageDescription PackageDescription + , HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo +configure (pkg_descr0, pbi) cfg + = do let verbosity = configVerbose cfg + cfg' = cfg { configVerbose = lessVerbose verbosity } + + setupMessage verbosity "Configuring" + (either packageDescription id pkg_descr0) + -- detect compiler - comp@(Compiler f' ver p' pkg) <- configCompilerAux cfg + (comp, programsConfig) <- configCompilerAux cfg' + let version = compilerVersion comp + flavor = compilerFlavor comp - -- installation directories - defPrefix <- default_prefix - defDataDir <- default_datadir pkg_descr - let - pref = fromMaybe defPrefix (configPrefix cfg) - my_bindir = fromMaybe default_bindir - (configBinDir cfg) - my_libdir = fromMaybe (default_libdir comp) - (configLibDir cfg) - my_libsubdir = fromMaybe (default_libsubdir comp) - (configLibSubDir cfg) - my_libexecdir = fromMaybe default_libexecdir - (configLibExecDir cfg) - my_datadir = fromMaybe defDataDir - (configDataDir cfg) - my_datasubdir = fromMaybe default_datasubdir - (configDataSubDir cfg) + -- FIXME: currently only GHC has hc-pkg + mipkgs <- getInstalledPackages (lessVerbose verbosity) comp + (configPackageDB cfg) programsConfig - -- check extensions - let extlist = nub $ maybe [] (extensions . libBuildInfo) lib ++ - concat [ extensions exeBi | Executable _ _ exeBi <- executables pkg_descr ] - let exts = fst $ extensionsToFlags f' extlist - unless (null exts) $ warn $ -- Just warn, FIXME: Should this be an error? - show f' ++ " does not support the following extensions:\n " ++ - concat (intersperse ", " (map show exts)) + (pkg_descr, flags) <- case pkg_descr0 of + Left ppd -> + case finalizePackageDescription + (configConfigurationsFlags cfg) + mipkgs + System.Info.os + System.Info.arch + (map toLower (show flavor),version) + 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) + Right pd -> return (pd,[]) + - foundPrograms <- lookupPrograms (configPrograms cfg) + when (not (null flags)) $ + info verbosity $ "Flags chosen: " ++ (concat . intersperse ", " . + map (\(n,b) -> n ++ "=" ++ show b) $ flags) - happy <- findProgram "happy" (configHappy cfg) - alex <- findProgram "alex" (configAlex cfg) - hsc2hs <- findProgram "hsc2hs" (configHsc2hs cfg) - c2hs <- findProgram "c2hs" (configC2hs cfg) - cpphs <- findProgram "cpphs" (configCpphs cfg) - greencard <- findProgram "greencard" (configGreencard cfg) + (warns, ers) <- sanityCheckPackage $ + updatePackageDescription pbi pkg_descr + + errorOut verbosity warns ers - let newConfig = foldr (\(_, p) c -> updateProgram p c) (configPrograms cfg) foundPrograms + let ipkgs = fromMaybe (map setDepByVersion (buildDepends pkg_descr)) mipkgs - -- FIXME: currently only GHC has hc-pkg - dep_pkgs <- case f' of - GHC | ver >= Version [6,3] [] -> do - ipkgs <- getInstalledPackagesAux comp cfg - mapM (configDependency ipkgs) (buildDepends pkg_descr) + dep_pkgs <- case flavor of + GHC | version >= Version [6,3] [] -> do + mapM (configDependency verbosity ipkgs) (buildDepends pkg_descr) JHC -> do - ipkgs <- getInstalledPackagesJHC comp cfg - mapM (configDependency ipkgs) (buildDepends pkg_descr) + mapM (configDependency verbosity ipkgs) (buildDepends pkg_descr) _ -> do return $ map setDepByVersion (buildDepends pkg_descr) + + removeInstalledConfig + + -- 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 + } + + -- 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)) + + let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) + programsConfig' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr', programsConfig'') <- configurePkgconfigPackages verbosity + pkg_descr programsConfig' + split_objs <- if not (configSplitObjs cfg) then return False - else case f' of - GHC | ver >= Version [6,5] [] -> return True - _ -> do warn ("this compiler does not support " ++ - "--enable-split-objs; ignoring") + else case flavor of + GHC | version >= Version [6,5] [] -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-objs; ignoring") return False - let lbi = LocalBuildInfo{prefix=pref, compiler=comp, - buildDir="dist" `joinFileName` "build", - bindir=my_bindir, - libdir=my_libdir, - libsubdir=my_libsubdir, - libexecdir=my_libexecdir, - datadir=my_datadir, - datasubdir=my_datasubdir, - packageDeps=dep_pkgs, - withPrograms=newConfig, - withHappy=happy, withAlex=alex, - withHsc2hs=hsc2hs, withC2hs=c2hs, - withCpphs=cpphs, - withGreencard=greencard, - withVanillaLib=configVanillaLib cfg, - withProfLib=configProfLib cfg, - withProfExe=configProfExe cfg, - withGHCiLib=configGHCiLib cfg, - splitObjs=split_objs, - userConf=configUser cfg - } + let lbi = LocalBuildInfo{ + installDirTemplates = installDirs, + compiler = comp, + buildDir = distPref "build", + scratchDir = distPref "scratch", + packageDeps = dep_pkgs, + localPkgDescr = pkg_descr', + withPrograms = programsConfig'', + withVanillaLib = configVanillaLib cfg, + withProfLib = configProfLib cfg, + withSharedLib = configSharedLib cfg, + withProfExe = configProfExe cfg, + withOptimization = configOptimization cfg, + withGHCiLib = configGHCiLib cfg, + splitObjs = split_objs, + withPackageDB = configPackageDB cfg + } - -- FIXME: maybe this should only be printed when verbose? - message $ "Using install prefix: " ++ pref + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs pkg_descr lbi - messageDir pkg_descr lbi "Binaries" mkBinDir mkBinDirRel - messageDir pkg_descr lbi "Libraries" mkLibDir mkLibDirRel - messageDir pkg_descr lbi "Private binaries" mkLibexecDir mkLibexecDirRel - messageDir pkg_descr lbi "Data files" mkDataDir mkDataDirRel - - message $ "Using compiler: " ++ p' - message $ "Compiler flavor: " ++ (show f') - message $ "Compiler version: " ++ showVersion ver - message $ "Using package tool: " ++ pkg + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs - mapM (\(s,p) -> reportProgram' s p) foundPrograms + 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)" + _ -> "" - reportProgram "happy" happy - reportProgram "alex" alex - reportProgram "hsc2hs" hsc2hs - reportProgram "c2hs" c2hs - reportProgram "cpphs" cpphs - reportProgram "greencard" greencard + dirinfo "Binaries" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + sequence_ [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programsConfig' ] + return lbi -messageDir :: PackageDescription -> LocalBuildInfo -> String - -> (PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath) - -> (PackageDescription -> LocalBuildInfo -> CopyDest -> Maybe FilePath) - -> IO () -messageDir pkg_descr lbi name mkDir mkDirRel = - message (name ++ " installed in: " ++ mkDir pkg_descr lbi NoCopyDest ++ rel_note) - where -#if mingw32_HOST_OS - rel_note - | not (hasLibs pkg_descr) && - mkDirRel pkg_descr lbi NoCopyDest == Nothing - = " (fixed location)" - | otherwise = "" -#else - rel_note = "" -#endif +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + -- |Converts build dependencies to a versioned dependency. only sets -- version information for exact versioned dependencies. setDepByVersion :: Dependency -> PackageIdentifier @@ -273,193 +340,163 @@ -- otherwise, just set it to empty setDepByVersion (Dependency s _) = PackageIdentifier s (Version [] []) +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing + = info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) + = info verbosity $ "Using " ++ programName prog ++ version ++ location + where location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ showVersion v --- |Return the explicit path if given, otherwise look for the program --- name in the path. -findProgram - :: String -- ^ program name - -> Maybe FilePath -- ^ optional explicit path - -> IO (Maybe FilePath) -findProgram name Nothing = findExecutable name -findProgram _ p = return p +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/" -reportProgram :: String -> Maybe FilePath -> IO () -reportProgram name Nothing = message ("No " ++ name ++ " found") -reportProgram name (Just p) = message ("Using " ++ name ++ ": " ++ p) +-- | 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" + ++ "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 -reportProgram' :: String -> Maybe Program -> IO () -reportProgram' _ (Just Program{ programName=name - , programLocation=EmptyLocation}) - = message ("No " ++ name ++ " found") -reportProgram' _ (Just Program{ programName=name - , programLocation=FoundOnSystem p}) - = message ("Using " ++ name ++ " found on system at: " ++ p) -reportProgram' _ (Just Program{ programName=name - , programLocation=UserSpecified p}) - = message ("Using " ++ name ++ " given by user at: " ++ p) -reportProgram' name Nothing = message ("No " ++ name ++ " found") +getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration + -> IO (Maybe [PackageIdentifier]) +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 + JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDb progconf + _ -> return Nothing +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies --- | Test for a package dependency and record the version we have installed. -configDependency :: [PackageIdentifier] -> Dependency -> IO PackageIdentifier -configDependency ps (Dependency pkgname vrange) = do - let - ok p = pkgName p == pkgname && pkgVersion p `withinRange` vrange - -- - case filter ok ps of - [] -> die ("cannot satisfy dependency " ++ - pkgname ++ showVersionRange vrange) - qs -> let - pkg = maximumBy versions qs - versions a b = pkgVersion a `compare` pkgVersion b - in do message ("Dependency " ++ pkgname ++ showVersionRange vrange ++ - ": using " ++ showPackageId pkg) - return pkg +configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration +configureRequiredPrograms verbosity deps conf = + foldM (configureRequiredProgram verbosity) conf deps -getInstalledPackagesJHC :: Compiler -> ConfigFlags -> IO [PackageIdentifier] -getInstalledPackagesJHC comp cfg = do - let verbose = configVerbose cfg - when (verbose > 0) $ message "Reading installed packages..." - let cmd_line = "\"" ++ compilerPkgTool comp ++ "\" --list-libraries" - str <- systemCaptureStdout verbose cmd_line - case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str) of - [ps] -> return ps - _ -> die "cannot parse package list" +configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration +configureRequiredProgram verbosity conf (Dependency progName verRange) = + case lookupKnownProgram progName conf of + Nothing -> die ("Unknown build tool " ++ show progName) + Just prog -> snd `fmap` requireProgram verbosity prog verRange conf -getInstalledPackagesAux :: Compiler -> ConfigFlags -> IO [PackageIdentifier] -getInstalledPackagesAux comp cfg = getInstalledPackages comp (configUser cfg) (configVerbose cfg) +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies -getInstalledPackages :: Compiler -> Bool -> Int -> IO [PackageIdentifier] -getInstalledPackages comp user verbose = do - when (verbose > 0) $ message "Reading installed packages..." - let user_flag = if user then "--user" else "--global" - cmd_line = "\"" ++ compilerPkgTool comp ++ "\" " ++ user_flag ++ " list" - str <- systemCaptureStdout verbose cmd_line - let keep_line s = ':' `notElem` s && not ("Creating" `isPrefixOf` s) - str1 = unlines (filter keep_line (lines str)) - str2 = filter (`notElem` ",()") str1 - -- - case pCheck (readP_to_S (many (skipSpaces >> parsePackageId)) str2) of - [ps] -> return ps - _ -> die "cannot parse package list" +configurePkgconfigPackages :: Verbosity -> PackageDescription + -> ProgramConfiguration + -> IO (PackageDescription, ProgramConfiguration) +configurePkgconfigPackages verbosity pkg_descr conf + | null allpkgs = return (pkg_descr, conf) + | otherwise = do + (_, conf') <- requireProgram (lessVerbose verbosity) pkgConfigProgram + (orLaterVersion $ Version [0,9,0] []) conf + mapM_ requirePkg allpkgs + lib' <- updateLibrary (library pkg_descr) + exes' <- mapM updateExecutable (executables pkg_descr) + let pkg_descr' = pkg_descr { library = lib', executables = exes' } + return (pkg_descr', conf') + + where + allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) + pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) + pkgConfigProgram conf -systemCaptureStdout :: Int -> String -> IO String -systemCaptureStdout verbose cmd = do - withTempFile "." "" $ \tmp -> do - let cmd_line = cmd ++ " >" ++ tmp - when (verbose > 0) $ putStrLn cmd_line - res <- system cmd_line - case res of - ExitFailure _ -> die ("executing external program failed: "++cmd_line) - ExitSuccess -> do str <- readFile tmp - let ev [] = ' '; ev xs = last xs - ev str `seq` return str + requirePkg (Dependency pkg range) = do + version <- pkgconfig ["--modversion", pkg] + `Exception.catch` \_ -> die notFound + case readVersion version of + Nothing -> die "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die (badVersion v) + | otherwise -> info verbosity (depSatisfied v) + where + notFound = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " ++ showVersion v + depSatisfied v = "Dependency " ++ pkg ++ showVersionRange range + ++ ": using version " ++ showVersion v + versionRequirement + | range == AnyVersion = "" + | otherwise = " version " ++ showVersionRange range + + updateLibrary Nothing = return Nothing + updateLibrary (Just lib) = do + let bi = libBuildInfo lib + bi' <- updateBuildInfo bi + return $ Just lib { libBuildInfo = bi' } + + updateExecutable exe = do + let bi = buildInfo exe + bi' <- updateBuildInfo bi + return exe { buildInfo = 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'' + } + -- ----------------------------------------------------------------------------- -- Determining the compiler details -configCompilerAux :: ConfigFlags -> IO Compiler +configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) configCompilerAux cfg = configCompiler (configHcFlavor cfg) (configHcPath cfg) (configHcPkg cfg) + (configPrograms cfg) (configVerbose cfg) -configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> Int -> IO Compiler -configCompiler hcFlavor hcPath hcPkg verbose - = do let flavor = case hcFlavor of - Just f -> f - Nothing -> error "Unknown compiler" - comp <- - case hcPath of - Just path -> do absolute <- doesFileExist path - if absolute - then return path - else findCompiler verbose path - Nothing -> findCompiler verbose (compilerBinaryName flavor) +configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> Verbosity + -> IO (Compiler, ProgramConfiguration) +configCompiler Nothing _ _ _ _ = die "Unknown compiler" +configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do + case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg conf + JHC -> JHC.configure verbosity hcPath hcPkg conf + Hugs -> Hugs.configure verbosity hcPath hcPkg conf + NHC -> NHC.configure verbosity hcPath hcPkg conf + _ -> die "Unknown compiler" - ver <- configCompilerVersion flavor comp verbose - pkgtool <- - case hcPkg of - Just path -> return path - Nothing -> guessPkgToolFromHCPath verbose flavor comp - - return (Compiler{compilerFlavor=flavor, - compilerVersion=ver, - compilerPath=comp, - compilerPkgTool=pkgtool}) - -findCompiler :: Int -> String -> IO FilePath -findCompiler verbose prog = do - when (verbose > 0) $ message $ "searching for " ++ prog ++ " in path." - res <- findExecutable prog - case res of - Nothing -> die ("Cannot find compiler for " ++ prog) - Just path -> do when (verbose > 0) $ message ("found " ++ prog ++ " at "++ path) - return path - -- ToDo: check that compiler works? - -compilerPkgToolName :: CompilerFlavor -> String -compilerPkgToolName GHC = "ghc-pkg" -compilerPkgToolName NHC = "hmake" -- FIX: nhc98-pkg Does not yet exist -compilerPkgToolName Hugs = "hugs" -compilerPkgToolName JHC = "jhc" -compilerPkgToolName cmp = error $ "Unsupported compiler: " ++ (show cmp) - -configCompilerVersion :: CompilerFlavor -> FilePath -> Int -> IO Version -configCompilerVersion GHC compilerP verbose = do - str <- systemGetStdout verbose ("\"" ++ compilerP ++ "\" --numeric-version") - case pCheck (readP_to_S parseVersion str) of - [v] -> return v - _ -> die ("cannot determine version of " ++ compilerP ++ ":\n "++ str) -configCompilerVersion JHC compilerP verbose = do - str <- systemGetStdout verbose ("\"" ++ compilerP ++ "\" --version") - case words str of - (_:ver:_) -> case pCheck $ readP_to_S parseVersion ver of - [v] -> return v - _ -> fail ("parsing version: "++ver++" failed.") - _ -> fail ("reading version string: "++show str++" failed.") -configCompilerVersion _ _ _ = return Version{ versionBranch=[],versionTags=[] } - -systemGetStdout :: Int -> String -> IO String -systemGetStdout verbose cmd = do - withTempFile "." "" $ \tmp -> do - let cmd_line = cmd ++ " >" ++ tmp - when (verbose > 0) $ putStrLn cmd_line - maybeExit $ system cmd_line - str <- readFile tmp - let eval [] = ' '; eval xs = last xs - eval str `seq` return str - -pCheck :: [(a, [Char])] -> [a] -pCheck rs = [ r | (r,s) <- rs, all isSpace s ] - -guessPkgToolFromHCPath :: Int -> CompilerFlavor -> FilePath -> IO FilePath -guessPkgToolFromHCPath verbose flavor path - = do let pkgToolName = compilerPkgToolName flavor - (dir,_) = splitFileName path - verSuffix = reverse $ takeWhile (`elem ` "0123456789.-") . reverse $ path - guessNormal = dir `joinFileName` pkgToolName `joinFileExt` exeExtension - guessVersioned = dir `joinFileName` (pkgToolName ++ verSuffix) `joinFileExt` exeExtension - guesses | null verSuffix = [guessNormal] - | otherwise = [guessVersioned, guessNormal] - message $ dir `joinFileName` (pkgToolName ++ verSuffix) `joinFileExt` exeExtension - when (verbose > 0) $ message $ "looking for package tool: " ++ pkgToolName ++ " near compiler in " ++ dir - file <- doesAnyFileExist guesses - case file of - Nothing -> die ("Cannot find package tool: " ++ pkgToolName) - Just pkgtool -> do when (verbose > 0) $ message $ "found package tool in " ++ pkgtool - return pkgtool - -doesAnyFileExist :: [FilePath] -> IO (Maybe FilePath) -doesAnyFileExist [] = return Nothing -doesAnyFileExist (file:files) = do exists <- doesFileExist file - if exists - then return $ Just file - else doesAnyFileExist files +-- |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) -message :: String -> IO () -message s = putStrLn $ "configure: " ++ s -- ----------------------------------------------------------------------------- -- Tests diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -2,12 +2,15 @@ ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC --- Copyright : Isaac Jones 2003-2006 +-- Copyright : Isaac Jones 2003-2007 -- -- Maintainer : Isaac Jones -- Stability : alpha -- Portability : portable -- +-- Build and Install implementations for GHC. See +-- 'Distribution.Simple.GHCPackageConfig.GHCPackageConfig' for +-- registration-related stuff. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -41,66 +44,219 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.GHC ( - build, installLib, installExe + configure, getInstalledPackages, build, makefile, installLib, installExe, + ghcVerbosityOptions ) where +import Distribution.Simple.GHC.Makefile +import Distribution.Simple.Setup ( MakefileFlags(..) ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), withLib, setupMessage, Executable(..), withExe, Library(..), libModules, hcOptions ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), autogenModulesDir, - mkLibDir, mkIncludeDir ) -import Distribution.Simple.Utils( rawSystemExit, rawSystemPath, - rawSystemVerbose, maybeExit, xargs, - die, dirOf, moduleToFilePath, - smartCopySources, findFile, copyFileVerbose, - mkLibName, mkProfLibName, dotToSep ) -import Distribution.Package ( PackageIdentifier(..), showPackageId ) -import Distribution.Program ( rawSystemProgram, ranlibProgram, - Program(..), ProgramConfiguration(..), - ProgramLocation(..), - lookupProgram, arProgram ) -import Distribution.Compiler ( Compiler(..), CompilerFlavor(..), - extensionsToGHCFlag ) -import Distribution.Version ( Version(..) ) -import Distribution.Compat.FilePath - ( joinFileName, exeExtension, joinFileExt, - splitFilePath, objExtension, joinPaths, - isAbsolutePath, splitFileExt ) -import Distribution.Compat.Directory - ( createDirectoryIfMissing ) -import qualified Distribution.Simple.GHCPackageConfig as GHC + ( LocalBuildInfo(..), autogenModulesDir ) +import Distribution.Simple.Utils +import Distribution.Package ( PackageIdentifier(..), showPackageId, + parsePackageId ) +import Distribution.Simple.Program ( rawSystemProgram, rawSystemProgramConf, + rawSystemProgramStdoutConf, + Program(..), ConfiguredProgram(..), + ProgramConfiguration, addKnownProgram, + userMaybeSpecifyPath, requireProgram, + programPath, lookupProgram, + ghcProgram, ghcPkgProgram, + arProgram, ranlibProgram, ldProgram ) +import Distribution.Simple.Compiler +import Distribution.Version ( Version(..), showVersion, + VersionRange(..), orLaterVersion ) +import qualified Distribution.Simple.GHC.PackageConfig as GHC ( localPackageConfig, canReadLocalPackageConfig ) +import Distribution.System +import Distribution.Verbosity import Language.Haskell.Extension (Extension(..)) +import Distribution.Compat.ReadP + ( readP_to_S, many, skipSpaces ) import Control.Monad ( unless, when ) -import Data.List ( isSuffixOf, nub ) +import Data.Char +import Data.List ( nub, isPrefixOf ) import System.Directory ( removeFile, renameFile, getDirectoryContents, doesFileExist ) -import System.Exit (ExitCode(..)) - -#ifdef mingw32_HOST_OS -import Distribution.Compat.FilePath ( splitFileName ) -#endif +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension, splitExtension ) +import System.IO +-- System.IO used to export a different try, so we can't use try unqualified #ifndef __NHC__ -import Control.Exception (try) +import Control.Exception as Try #else -import IO (try) +import IO as Try #endif -- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf = do + + (ghcProg, conf') <- requireProgram verbosity ghcProgram + (orLaterVersion (Version [6,2] [])) + (userMaybeSpecifyPath "ghc" hcPath conf) + let Just ghcVersion = programVersion ghcProg + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, conf'') <- requireProgram verbosity ghcPkgProgram { + programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + (orLaterVersion (Version [0] [])) + (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf') + 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 + + -- finding ghc's local ld is a bit tricky as it's not on the path: + let conf''' = case os of + Windows _ -> + let compilerDir = takeDirectory (programPath ghcProg) + baseDir = takeDirectory compilerDir + binInstallLd = baseDir "gcc-lib" "ld.exe" + in addKnownProgram ldProgram { + programFindLocation = \_ -> return (Just binInstallLd) + } conf'' + _ -> conf'' + + 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) ] + else return oldLanguageExtensions + + let comp = Compiler { + compilerFlavor = GHC, + compilerId = PackageIdentifier "ghc" ghcVersion, + compilerExtensions = languageExtensions + } + return (comp, conf''') + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath) +guessGhcPkgFromGhcPath ghcProg verbosity + = do let path = programPath ghcProg + dir = takeDirectory path + versionSuffix = takeVersionSuffix (dropExeExtension path) + guessNormal = dir "ghc-pkg" <.> exeExtension + guessVersioned = dir ("ghc-pkg" ++ versionSuffix) <.> exeExtension + guesses | null versionSuffix = [guessNormal] + | otherwise = [guessVersioned, guessNormal] + info verbosity $ "looking for package tool: ghc-pkg near compiler in " ++ dir + exists <- mapM doesFileExist guesses + case [ file | (file, True) <- zip guesses exists ] of + [] -> return Nothing + (pkgtool:_) -> do info verbosity $ "found package tool in " ++ pkgtool + return (Just pkgtool) + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse + + dropExeExtension :: FilePath -> FilePath + dropExeExtension filepath = + case splitExtension filepath of + (filepath', extension) | extension == exeExtension -> filepath' + | otherwise -> filepath + +-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags +oldLanguageExtensions :: [(Extension, Flag)] +oldLanguageExtensions = + [(OverlappingInstances , "-fallow-overlapping-instances") + ,(TypeSynonymInstances , "-fglasgow-exts") + ,(TemplateHaskell , "-fth") + ,(ForeignFunctionInterface , "-fffi") + ,(NoMonomorphismRestriction , "-fno-monomorphism-restriction") + ,(UndecidableInstances , "-fallow-undecidable-instances") + ,(IncoherentInstances , "-fallow-incoherent-instances") + ,(Arrows , "-farrows") + ,(Generics , "-fgenerics") + ,(NoImplicitPrelude , "-fno-implicit-prelude") + ,(ImplicitParams , "-fimplicit-params") + ,(CPP , "-cpp") + ,(BangPatterns , "-fbang-patterns") + ,(KindSignatures , fglasgowExts) + ,(RecursiveDo , fglasgowExts) + ,(ParallelListComp , fglasgowExts) + ,(MultiParamTypeClasses , fglasgowExts) + ,(FunctionalDependencies , fglasgowExts) + ,(Rank2Types , fglasgowExts) + ,(RankNTypes , fglasgowExts) + ,(PolymorphicComponents , fglasgowExts) + ,(ExistentialQuantification , fglasgowExts) + ,(ScopedTypeVariables , fglasgowExts) + ,(FlexibleContexts , fglasgowExts) + ,(FlexibleInstances , fglasgowExts) + ,(EmptyDataDecls , fglasgowExts) + ,(PatternGuards , fglasgowExts) + ,(GeneralizedNewtypeDeriving , fglasgowExts) + ,(MagicHash , fglasgowExts) + ] + where + fglasgowExts = "-fglasgow-exts" + +getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration + -> IO [PackageIdentifier] +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" + where + 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) + +-- ----------------------------------------------------------------------------- -- Building -- |Building for GHC. If .ghc-packages exists and is readable, add -- it to the command-line. -build :: PackageDescription -> LocalBuildInfo -> Int -> IO () -build pkg_descr lbi verbose = do +build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +build pkg_descr lbi verbosity = do let pref = buildDir lbi - let ghcPath = compilerPath (compiler lbi) + runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) ifProfLib = when (withProfLib lbi) ifGHCiLib = when (withGHCiLib lbi) @@ -117,15 +273,15 @@ -- Build lib withLib pkg_descr () $ \lib -> do - when (verbose > 3) (putStrLn "Building library...") + info verbosity "Building library..." let libBi = libBuildInfo lib libTargetDir = pref forceVanillaLib = TemplateHaskell `elem` extensions libBi -- TH always needs vanilla libs, even when building for profiling - createDirectoryIfMissing True libTargetDir + createDirectoryIfMissingVerbose verbosity True libTargetDir -- put hi-boot files into place for mutually recurive modules - smartCopySources verbose (hsSourceDirs libBi) + smartCopySources verbosity (hsSourceDirs libBi) libTargetDir (libModules pkg_descr) ["hi-boot"] False False let ghc_vers = compilerVersion (compiler lbi) packageId | versionBranch ghc_vers >= [6,4] @@ -135,8 +291,7 @@ ghcArgs = pkg_conf ++ ["-package-name", packageId ] - ++ (if splitObjs lbi then ["-split-objs"] else []) - ++ constructGHCCmdLine lbi libBi libTargetDir verbose + ++ constructGHCCmdLine lbi libBi libTargetDir verbosity ++ (libModules pkg_descr) ghcArgsProf = ghcArgs ++ ["-prof", @@ -145,30 +300,21 @@ ] ++ ghcProfOptions libBi unless (null (libModules pkg_descr)) $ - do ifVanillaLib forceVanillaLib (rawSystemExit verbose ghcPath ghcArgs) - ifProfLib (rawSystemExit verbose ghcPath ghcArgsProf) + do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs) + ifProfLib (runGhcProg ghcArgsProf) -- build any C sources unless (null (cSources libBi)) $ do - when (verbose > 3) (putStrLn "Building C Sources...") - -- FIX: similar 'versionBranch' logic duplicated below. refactor for code sharing - sequence_ [do let ghc_vers = compilerVersion (compiler lbi) - odir | versionBranch ghc_vers >= [6,4,1] = pref - | otherwise = pref `joinFileName` dirOf c - -- ghc 6.4.1 fixed a bug in -odir handling - -- for C compilations. - createDirectoryIfMissing True odir - let cArgs = ["-I" ++ dir | dir <- includeDirs libBi] - ++ ["-optc" ++ opt | opt <- ccOptions libBi] - ++ ["-odir", odir, "-hidir", pref, "-c"] - ++ (if verbose > 4 then ["-v"] else []) - rawSystemExit verbose ghcPath (cArgs ++ [c]) - | c <- cSources libBi] + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi pref + filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources libBi] -- link: - when (verbose > 3) (putStrLn "cabal-linking...") - let cObjs = [ path `joinFileName` file `joinFileExt` objExtension - | (path, file, _) <- (map splitFilePath (cSources libBi)) ] + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) libName = mkLibName pref (showPackageId (package pkg_descr)) profLibName = mkProfLibName pref (showPackageId (package pkg_descr)) ghciLibName = mkGHCiLibName pref (showPackageId (package pkg_descr)) @@ -187,108 +333,100 @@ else return [] unless (null hObjs && null cObjs && null stubObjs) $ do - try (removeFile libName) -- first remove library if it exists - try (removeFile profLibName) -- first remove library if it exists - try (removeFile ghciLibName) -- first remove library if it exists - let arArgs = ["q"++ (if verbose > 4 then "v" else "")] + Try.try (removeFile libName) -- first remove library if it exists + Try.try (removeFile profLibName) -- first remove library if it exists + Try.try (removeFile ghciLibName) -- first remove library if it exists + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + arArgs = ["q"++ arVerbosity] ++ [libName] arObjArgs = hObjs - ++ map (pref `joinFileName`) cObjs + ++ map (pref ) cObjs ++ stubObjs - arProfArgs = ["q"++ (if verbose > 4 then "v" else "")] + arProfArgs = ["q"++ arVerbosity] ++ [profLibName] arProfObjArgs = hProfObjs - ++ map (pref `joinFileName`) cObjs + ++ map (pref ) cObjs ++ stubProfObjs ldArgs = ["-r"] ++ ["-x"] -- FIXME: only some systems's ld support the "-x" flag - ++ ["-o", ghciLibName `joinFileExt` "tmp"] + ++ ["-o", ghciLibName <.> "tmp"] ldObjArgs = hObjs - ++ map (pref `joinFileName`) cObjs + ++ map (pref ) cObjs ++ stubObjs -#if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS) - (compilerDir, _) = splitFileName $ compilerPath (compiler lbi) - (baseDir, _) = splitFileName compilerDir - ld = baseDir `joinFileName` "gcc-lib\\ld.exe" - rawSystemLd = rawSystemVerbose - maxCommandLineSize = 30 * 1024 -#else - ld = "ld" - rawSystemLd = rawSystemPath + runLd args = do + exists <- doesFileExist ghciLibName + -- SDM: we always remove ghciLibName above, so isn't this + -- always False? What is this stuff for anyway? + rawSystemProgramConf verbosity ldProgram (withPrograms lbi) + (args ++ if exists then [ghciLibName] else []) + renameFile (ghciLibName <.> "tmp") ghciLibName + + runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) + --TODO: discover this at configure time on unix maxCommandLineSize = 30 * 1024 -#endif - runLd ld args = do - exists <- doesFileExist ghciLibName - status <- rawSystemLd verbose ld - (args ++ if exists then [ghciLibName] else []) - when (status == ExitSuccess) - (renameFile (ghciLibName `joinFileExt` "tmp") ghciLibName) - return status - ifVanillaLib False $ maybeExit $ xargs maxCommandLineSize - (rawSystemPath verbose) "ar" arArgs arObjArgs + ifVanillaLib False $ xargs maxCommandLineSize + runAr arArgs arObjArgs - ifProfLib $ maybeExit $ xargs maxCommandLineSize - (rawSystemPath verbose) "ar" arProfArgs arProfObjArgs + ifProfLib $ xargs maxCommandLineSize + runAr arProfArgs arProfObjArgs - ifGHCiLib $ maybeExit $ xargs maxCommandLineSize - runLd ld ldArgs ldObjArgs + ifGHCiLib $ xargs maxCommandLineSize + runLd ldArgs ldObjArgs -- build any executables withExe pkg_descr $ \ (Executable exeName' modPath exeBi) -> do - when (verbose > 3) - (putStrLn $ "Building executable: " ++ exeName' ++ "...") + info verbosity $ "Building executable: " ++ exeName' ++ "..." -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' `joinFileExt` - (if null $ snd $ splitFileExt exeName' then exeExtension else "") + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") - let targetDir = pref `joinFileName` exeName' - let exeDir = joinPaths targetDir (exeName' ++ "-tmp") - createDirectoryIfMissing True targetDir - createDirectoryIfMissing True exeDir + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir -- put hi-boot files into place for mutually recursive modules -- FIX: what about exeName.hi-boot? - smartCopySources verbose (hsSourceDirs exeBi) + smartCopySources verbosity (hsSourceDirs exeBi) exeDir (otherModules exeBi) ["hi-boot"] False False -- build executables unless (null (cSources exeBi)) $ do - when (verbose > 3) (putStrLn "Building C Sources.") - sequence_ [do let cSrcODir |versionBranch (compilerVersion (compiler lbi)) - >= [6,4,1] = exeDir - | otherwise - = exeDir `joinFileName` (dirOf c) - createDirectoryIfMissing True cSrcODir - let cArgs = ["-I" ++ dir | dir <- includeDirs exeBi] - ++ ["-optc" ++ opt | opt <- ccOptions exeBi] - ++ ["-odir", cSrcODir, "-hidir", pref, "-c"] - ++ (if verbose > 4 then ["-v"] else []) - rawSystemExit verbose ghcPath (cArgs ++ [c]) - | c <- cSources exeBi] - srcMainFile <- findFile (hsSourceDirs exeBi) modPath + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi + exeDir filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] - let cObjs = [ path `joinFileName` file `joinFileExt` objExtension - | (path, file, _) <- (map splitFilePath (cSources exeBi)) ] + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) let binArgs linkExe profExe = pkg_conf - ++ ["-I"++pref] ++ (if linkExe - then ["-o", targetDir `joinFileName` exeNameReal] + then ["-o", targetDir exeNameReal] else ["-c"]) - ++ constructGHCCmdLine lbi exeBi exeDir verbose - ++ [exeDir `joinFileName` x | x <- cObjs] + ++ constructGHCCmdLine lbi exeBi exeDir verbosity + ++ [exeDir x | x <- cObjs] ++ [srcMainFile] ++ ldOptions exeBi ++ ["-l"++lib | lib <- extraLibs exeBi] ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] ++ if profExe - then "-prof":ghcProfOptions exeBi + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ ghcProfOptions exeBi else [] -- For building exe's for profiling that use TH we actually @@ -297,139 +435,205 @@ -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi) - (rawSystemExit verbose ghcPath (binArgs False False)) + (runGhcProg (binArgs False False)) - rawSystemExit verbose ghcPath (binArgs True (withProfExe lbi)) + runGhcProg (binArgs True (withProfExe lbi)) -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: PackageDescription -> BuildInfo -> LocalBuildInfo -> FilePath -> String -> IO [FilePath] -getHaskellObjects pkg_descr libBi lbi pref wanted_obj_ext +getHaskellObjects pkg_descr _ lbi pref wanted_obj_ext | splitObjs lbi = do - let dirs = [ pref `joinFileName` (dotToSep x ++ "_split") + let dirs = [ pref (dotToSep x ++ "_split") | x <- libModules pkg_descr ] objss <- mapM getDirectoryContents dirs - let objs = [ dir `joinFileName` obj - | (objs,dir) <- zip objss dirs, obj <- objs, - let (_,obj_ext) = splitFileExt obj, - wanted_obj_ext == obj_ext ] + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] return objs | otherwise = - return [ pref `joinFileName` (dotToSep x) `joinFileExt` wanted_obj_ext + return [ pref dotToSep x <.> wanted_obj_ext | x <- libModules pkg_descr ] constructGHCCmdLine - :: LocalBuildInfo + :: LocalBuildInfo -> BuildInfo - -> FilePath - -> Int -- verbosity level + -> FilePath + -> Verbosity -> [String] -constructGHCCmdLine lbi bi odir verbose = +constructGHCCmdLine lbi bi odir verbosity = ["--make"] - ++ (if verbose > 4 then ["-v"] else []) - -- Unsupported extensions have already been checked by configure - ++ (if compilerVersion (compiler lbi) > Version [6,4] [] + ++ ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] +ghcOptions lbi bi odir + = (if compilerVersion c > Version [6,4] [] then ["-hide-all-packages"] else []) + ++ (if splitObjs lbi then ["-split-objs"] else []) ++ ["-i"] ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-i" ++ odir] ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-I" ++ odir] ++ ["-I" ++ dir | dir <- includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] ++ ["-optc" ++ opt | opt <- ccOptions bi] - ++ [ "-#include \"" ++ inc ++ "\"" | inc <- includes bi ++ installIncludes bi ] + ++ [ "-#include \"" ++ inc ++ "\"" | inc <- includes bi ] ++ [ "-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) - ++ snd (extensionsToGHCFlag (extensions bi)) + ++ extensionsToFlags c (extensions bi) + where c = compiler lbi +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath + -> FilePath -> Verbosity -> (FilePath,[String]) +constructCcCmdLine lbi bi pref filename verbosity + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi odir + ++ (if verbosity > deafening then ["-v"] else []) + ++ ["-c",filename]) + + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> FilePath -> [String] +ghcCcOptions lbi bi odir + = ["-I" ++ dir | dir <- includeDirs bi] + ++ concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ] + ++ ["-optc" ++ opt | opt <- ccOptions bi] + ++ (if withOptimization lbi then ["-optc-O2"] else []) + ++ ["-odir", odir] + mkGHCiLibName :: FilePath -- ^file Prefix -> String -- ^library name. -> String -mkGHCiLibName pref lib = pref `joinFileName` ("HS" ++ lib ++ ".o") +mkGHCiLibName pref lib = pref ("HS" ++ 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" + targetExists <- doesFileExist file + when targetExists $ + die ("Not overwriting existing copy of " ++ file) + h <- openFile file WriteMode + + 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 + (withPrograms lbi) + (ldProg, _) <- requireProgram (makefileVerbose flags) 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), + ("WAYS", if withProfLib lbi then "p" else ""), + ("odir", builddir), + ("srcdir", case hsSourceDirs bi of + [one] -> one + _ -> error "makefile: can't cope with multiple hs-source-dirs yet, sorry"), + ("package", packageId), + ("GHC_OPTS", unwords ( + ["-package-name", packageId ] + ++ 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))), + ("AR", programPath arProg), + ("LD", programPath ldProg) + ] + hPutStrLn h "# DO NOT EDIT! Automatically generated by Cabal\n" + hPutStrLn h (unlines (map (\(a,b)-> a ++ " = " ++ munge b) decls)) + hPutStrLn h makefileTemplate + hClose h + where + munge "" = "" + munge ('#':s) = '\\':'#':munge s + munge ('\\':s) = '/':munge s + -- for Windows, we want to use forward slashes in our pathnames in the Makefile + munge (c:s) = c : munge s + +-- ----------------------------------------------------------------------------- -- Installing -- |Install executables for GHC. -installExe :: Int -- ^verbose - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription -> IO () -installExe verbose pref buildPref pkg_descr - = do createDirectoryIfMissing True pref - withExe pkg_descr $ \ (Executable e _ b) -> do - let exeName = e `joinFileExt` exeExtension - copyFileVerbose verbose (buildPref `joinFileName` e `joinFileName` exeName) (pref `joinFileName` exeName) +installExe :: Verbosity -- ^verbosity + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> PackageDescription + -> IO () +installExe verbosity pref buildPref pkg_descr + = do createDirectoryIfMissingVerbose verbosity True pref + withExe pkg_descr $ \ (Executable e _ _) -> do + let exeFileName = e <.> exeExtension + copyFileVerbose verbosity (buildPref e exeFileName) (pref exeFileName) -- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Int -- ^verbose +installLib :: Verbosity -- ^verbosity -> ProgramConfiguration - -> Bool -- ^has vanilla library - -> Bool -- ^has profiling library - -> Bool -- ^has GHCi libs - -> FilePath -- ^install location - -> FilePath -- ^Build location + -> Bool -- ^has vanilla library + -> Bool -- ^has profiling library + -> Bool -- ^has GHCi libs + -> FilePath -- ^install location + -> FilePath -- ^Build location -> PackageDescription -> IO () -installLib verbose programConf hasVanilla hasProf hasGHCi pref buildPref - pd@PackageDescription{library=Just l, +installLib verbosity programConf hasVanilla hasProf hasGHCi pref buildPref + pd@PackageDescription{library=Just _, package=p} - = do ifVanilla $ smartCopySources verbose [buildPref] pref (libModules pd) ["hi"] True False - ifProf $ smartCopySources verbose [buildPref] pref (libModules pd) ["p_hi"] True False + = do 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) - ifVanilla $ copyFileVerbose verbose (mkLibName buildPref (showPackageId p)) libTargetLoc - ifProf $ copyFileVerbose verbose (mkProfLibName buildPref (showPackageId p)) profLibTargetLoc - ifGHCi $ copyFileVerbose verbose (mkGHCiLibName buildPref (showPackageId p)) libGHCiTargetLoc - - installIncludeFiles verbose pd pref + ifVanilla $ copyFileVerbose verbosity (mkLibName buildPref (showPackageId p)) libTargetLoc + ifProf $ copyFileVerbose verbosity (mkProfLibName buildPref (showPackageId p)) profLibTargetLoc + ifGHCi $ copyFileVerbose verbosity (mkGHCiLibName buildPref (showPackageId p)) libGHCiTargetLoc -- 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. - let progName = programName $ ranlibProgram - mProg <- lookupProgram progName programConf - case foundProg mProg of - Just rl -> do ifVanilla $ rawSystemProgram verbose rl [libTargetLoc] - ifProf $ rawSystemProgram verbose rl [profLibTargetLoc] + case lookupProgram ranlibProgram programConf of + Just rl -> do ifVanilla $ rawSystemProgram verbosity rl [libTargetLoc] + ifProf $ rawSystemProgram verbosity rl [profLibTargetLoc] - Nothing -> do let progName = programName $ arProgram - mProg <- lookupProgram progName programConf - case mProg of - Just ar -> do ifVanilla $ rawSystemProgram verbose ar ["-s", libTargetLoc] - ifProf $ rawSystemProgram verbose ar ["-s", profLibTargetLoc] - Nothing -> setupMessage "Warning: Unable to generate index for library (missing ranlib and ar)" pd + 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 hasVanilla (action >> return ()) ifProf action = when hasProf (action >> return ()) ifGHCi action = when hasGHCi (action >> return ()) installLib _ _ _ _ _ _ _ PackageDescription{library=Nothing} = die $ "Internal Error. installLibGHC called with no library." - --- | Install the files listed in install-includes -installIncludeFiles :: Int -> PackageDescription -> FilePath -> IO () -installIncludeFiles verbose pkg_descr@PackageDescription{library=Just l} libdir - = do - createDirectoryIfMissing True incdir - incs <- mapM (findInc relincdirs) (installIncludes lbi) - sequence_ [ copyFileVerbose verbose path (incdir `joinFileName` f) - | (f,path) <- incs ] - where - relincdirs = filter (not.isAbsolutePath) (includeDirs lbi) - lbi = libBuildInfo l - incdir = mkIncludeDir libdir - - findInc [] f = die ("can't find include file " ++ f) - findInc (d:ds) f = do - let path = (d `joinFileName` f) - b <- doesFileExist path - if b then return (f,path) else findInc ds f - --- Also checks whether the program was actually found. -foundProg :: Maybe Program -> Maybe Program -foundProg Nothing = Nothing -foundProg (Just Program{programLocation=EmptyLocation}) = Nothing -foundProg x = x diff --git a/Distribution/Simple/GHC/Makefile.hs b/Distribution/Simple/GHC/Makefile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/Makefile.hs @@ -0,0 +1,5 @@ +-- DO NOT EDIT: change Makefile.in, and run ../../../mkGHCMakefile.sh +module Distribution.Simple.GHC.Makefile where { +makefileTemplate :: String; makefileTemplate=unlines +["# -----------------------------------------------------------------------------","# Makefile template starts here.","","GHC_OPTS += -i$(odir)","","# For adding options on the command-line","GHC_OPTS += $(EXTRA_HC_OPTS)","","WAY_p_OPTS = -prof","","ifneq \"$(way)\" \"\"","way_ := $(way)_","_way := _$(way)","GHC_OPTS += $(WAY_$(way)_OPTS)","GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf)","endif","osuf = $(way_)o","hisuf = $(way_)hi","","HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules)))","HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules)))","C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS))","","LIB = $(odir)/libHS$(package)$(_way).a","","RM = rm -f","","# Optionally include local customizations:","-include Makefile.local","","# Rules follow:","","MKSTUBOBJS = find $(odir) -name \"*_stub.$(osuf)\" -print","# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to ","# make using cached directory contents, or something.","","all :: .depend $(LIB)","",".depend : $(MAKEFILE)","\t$(GHC) -M -optdep-f -optdep.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules)","\tfor dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \\","\t\tif test ! -d $$dir; then mkdir -p $$dir; fi \\","\tdone","","include .depend","","ifneq \"$(filter -split-objs, $(GHC_OPTS))\" \"\"","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t(echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs -s 30000 $(AR) q $(EXTRA_AR_ARGS) $@ ","else","$(LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\techo $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` | xargs -s 30000 $(AR) q $(EXTRA_AR_ARGS) $@ ","endif","","ifneq \"$(GHCI_LIB)\" \"\"","ifeq \"$(way)\" \"\"","all :: $(GHCI_LIB)","","$(GHCI_LIB) : $(HS_OBJS) $(C_OBJS)","\t@$(RM) $@","\t$(LD) -r -x -o $@ $(EXTRA_LD_OPTS) $(HS_OBJS) `$(MKSTUBOBJS)` $(C_OBJS)","endif","endif","","# suffix rules","","ifneq \"$(odir)\" \"\"","odir_ = $(odir)/","else","odir_ =","endif","","$(odir_)%.$(osuf) : $(srcdir)/%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(srcdir)/%.lhs\t ","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","# The .hs files might be in $(odir) if they were preprocessed","$(odir_)%.$(osuf) : $(odir_)%.hs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(odir_)%.lhs","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf)","","$(odir_)%.$(osuf) : $(srcdir)/%.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(osuf) : $(srcdir)/%.$(way_)s","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(osuf) : $(srcdir)/%.S","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -c $< -o $@","","$(odir_)%.$(way_)s : $(srcdir)/%.c","\t@$(RM) $@","\t$(GHC) $(GHC_CC_OPTS) -S $< -o $@","","$(odir_)%.$(osuf)-boot : $(srcdir)/%.hs-boot","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot","","$(odir_)%.$(osuf)-boot : $(srcdir)/%.lhs-boot","\t$(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot","","%.$(hisuf) : %.$(osuf)","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","%.$(way_)hi-boot : %.$(osuf)-boot","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","$(odir_)%.$(hisuf) : %.$(way_)hc","\t@if [ ! -f $@ ] ; then \\","\t echo Panic! $< exists, but $@ does not.; \\","\t exit 1; \\","\telse exit 0 ; \\","\tfi","","show:","\t@echo '$(VALUE)=\"$($(VALUE))\"'","","clean ::","\t$(RM) $(HS_OBJS) $(C_OBJS) $(LIB) $(GHCI_LIB) $(HS_IFS) .depend","\t$(RM) -rf $(wildcard $(patsubst %.$(osuf), %_split, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.o-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %.hi-boot, $(HS_OBJS)))","\t$(RM) $(wildcard $(patsubst %.$(osuf), %_stub.o, $(HS_OBJS)))","","ifneq \"$(strip $(WAYS))\" \"\"","ifeq \"$(way)\" \"\"","all clean ::","# Don't rely on -e working, instead we check exit return codes from sub-makes.","\t@case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \\","\tfor i in $(WAYS) ; do \\","\t echo \"== $(MAKE) way=$$i -f $(MAKEFILE) $@;\"; \\","\t $(MAKE) way=$$i -f $(MAKEFILE) --no-print-directory $(MFLAGS) $@ ; \\","\t if [ $$? -eq 0 ] ; then true; else exit $$x_on_err; fi; \\","\tdone","\t@echo \"== Finished recursively making \\`$@' for ways: $(WAYS) ...\"","endif","endif",""] +} diff --git a/Distribution/Simple/GHC/Makefile.in b/Distribution/Simple/GHC/Makefile.in new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/Makefile.in @@ -0,0 +1,154 @@ +# ----------------------------------------------------------------------------- +# Makefile template starts here. + +GHC_OPTS += -i$(odir) + +# For adding options on the command-line +GHC_OPTS += $(EXTRA_HC_OPTS) + +WAY_p_OPTS = -prof + +ifneq "$(way)" "" +way_ := $(way)_ +_way := _$(way) +GHC_OPTS += $(WAY_$(way)_OPTS) +GHC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(osuf) +endif +osuf = $(way_)o +hisuf = $(way_)hi + +HS_OBJS = $(patsubst %,$(odir)/%.$(osuf),$(subst .,/,$(modules))) +HS_IFS = $(patsubst %,$(odir)/%.$(hisuf),$(subst .,/,$(modules))) +C_OBJS = $(patsubst %.c,$(odir)/%.$(osuf),$(C_SRCS)) + +LIB = $(odir)/libHS$(package)$(_way).a + +RM = rm -f + +# Optionally include local customizations: +-include Makefile.local + +# Rules follow: + +MKSTUBOBJS = find $(odir) -name "*_stub.$(osuf)" -print +# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to +# make using cached directory contents, or something. + +all :: $(odir)/.depend $(LIB) + +$(odir)/.depend : $(MAKEFILE) + $(GHC) -M -optdep-f -optdep$(odir)/.depend $(foreach way,$(WAYS),-optdep-s -optdep$(way)) $(foreach obj,$(MKDEPENDHS_OBJ_SUFFICES),-osuf $(obj)) $(filter-out -split-objs, $(GHC_OPTS)) $(modules) + for dir in $(sort $(foreach mod,$(HS_OBJS) $(C_OBJS),$(dir $(mod)))); do \ + if test ! -d $$dir; then mkdir -p $$dir; fi \ + done + +include $(odir)/.depend + +ifneq "$(filter -split-objs, $(GHC_OPTS))" "" +$(LIB) : $(HS_OBJS) $(C_OBJS) + @$(RM) $@ + (echo $(C_OBJS) `$(MKSTUBOBJS)`; find $(patsubst %.$(osuf),%_split,$(HS_OBJS)) -name '*.$(way_)o' -print) | xargs -s 30000 $(AR) q $(EXTRA_AR_ARGS) $@ +else +$(LIB) : $(HS_OBJS) $(C_OBJS) + @$(RM) $@ + echo $(C_OBJS) $(HS_OBJS) `$(MKSTUBOBJS)` | xargs -s 30000 $(AR) q $(EXTRA_AR_ARGS) $@ +endif + +ifneq "$(GHCI_LIB)" "" +ifeq "$(way)" "" +all :: $(GHCI_LIB) + +$(GHCI_LIB) : $(HS_OBJS) $(C_OBJS) + @$(RM) $@ + $(LD) -r -x -o $@ $(EXTRA_LD_OPTS) $(HS_OBJS) `$(MKSTUBOBJS)` $(C_OBJS) +endif +endif + +# suffix rules + +ifneq "$(odir)" "" +odir_ = $(odir)/ +else +odir_ = +endif + +$(odir_)%.$(osuf) : $(srcdir)/%.hs + $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) + +$(odir_)%.$(osuf) : $(srcdir)/%.lhs + $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) + +# The .hs files might be in $(odir) if they were preprocessed +$(odir_)%.$(osuf) : $(odir_)%.hs + $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) + +$(odir_)%.$(osuf) : $(odir_)%.lhs + $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(hisuf) + +$(odir_)%.$(osuf) : $(srcdir)/%.c + @$(RM) $@ + $(GHC) $(GHC_CC_OPTS) -c $< -o $@ + +$(odir_)%.$(osuf) : $(srcdir)/%.$(way_)s + @$(RM) $@ + $(GHC) $(GHC_CC_OPTS) -c $< -o $@ + +$(odir_)%.$(osuf) : $(srcdir)/%.S + @$(RM) $@ + $(GHC) $(GHC_CC_OPTS) -c $< -o $@ + +$(odir_)%.$(way_)s : $(srcdir)/%.c + @$(RM) $@ + $(GHC) $(GHC_CC_OPTS) -S $< -o $@ + +$(odir_)%.$(osuf)-boot : $(srcdir)/%.hs-boot + $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot + +$(odir_)%.$(osuf)-boot : $(srcdir)/%.lhs-boot + $(GHC) $(GHC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi-boot + +%.$(hisuf) : %.$(osuf) + @if [ ! -f $@ ] ; then \ + echo Panic! $< exists, but $@ does not.; \ + exit 1; \ + else exit 0 ; \ + fi + +%.$(way_)hi-boot : %.$(osuf)-boot + @if [ ! -f $@ ] ; then \ + echo Panic! $< exists, but $@ does not.; \ + exit 1; \ + else exit 0 ; \ + fi + +$(odir_)%.$(hisuf) : %.$(way_)hc + @if [ ! -f $@ ] ; then \ + echo Panic! $< exists, but $@ does not.; \ + exit 1; \ + else exit 0 ; \ + fi + +show: + @echo '$(VALUE)="$($(VALUE))"' + +clean :: + $(RM) $(HS_OBJS) $(C_OBJS) $(LIB) $(GHCI_LIB) $(HS_IFS) .depend + $(RM) -rf $(wildcard $(patsubst %.$(osuf), %_split, $(HS_OBJS))) + $(RM) $(wildcard $(patsubst %.$(osuf), %.o-boot, $(HS_OBJS))) + $(RM) $(wildcard $(patsubst %.$(osuf), %.hi-boot, $(HS_OBJS))) + $(RM) $(wildcard $(patsubst %.$(osuf), %_stub.o, $(HS_OBJS))) + +ifneq "$(strip $(WAYS))" "" +ifeq "$(way)" "" +all clean :: +# Don't rely on -e working, instead we check exit return codes from sub-makes. + @case '${MFLAGS}' in *-[ik]*) x_on_err=0;; *-r*[ik]*) x_on_err=0;; *) x_on_err=1;; esac; \ + for i in $(WAYS) ; do \ + echo "== $(MAKE) way=$$i -f $(MAKEFILE) $@;"; \ + $(MAKE) way=$$i -f $(MAKEFILE) --no-print-directory $(MFLAGS) $@ ; \ + if [ $$? -eq 0 ] ; then true; else exit $$x_on_err; fi; \ + done + @echo "== Finished recursively making \`$@' for ways: $(WAYS) ..." +endif +endif + diff --git a/Distribution/Simple/GHC/PackageConfig.hs b/Distribution/Simple/GHC/PackageConfig.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/PackageConfig.hs @@ -0,0 +1,169 @@ +{-# 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/GHCPackageConfig.hs b/Distribution/Simple/GHCPackageConfig.hs deleted file mode 100644 --- a/Distribution/Simple/GHCPackageConfig.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.GHCPackageConfig --- 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. - -module Distribution.Simple.GHCPackageConfig ( - 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(..),mkLibDir) -import Distribution.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 Distribution.Compat.FilePath (joinFileName) -import Distribution.Compat.Directory (getHomeDirectory) - --- |Where ghc keeps the --user files. --- |return the file, whether it exists, and whether it's readable - -localPackageConfig :: IO FilePath -localPackageConfig = do u <- getHomeDirectory - return $ (u `joinFileName` ".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 = pkg_name, - auto = True, - import_dirs = [mkLibDir pkg_descr lbi NoCopyDest], - library_dirs = (mkLibDir pkg_descr lbi NoCopyDest: - maybe [] (extraLibDirs . libBuildInfo) (library pkg_descr)), - hs_libraries = ["HS"++(showPackageId (package pkg_descr))], - extra_libraries = maybe [] (extraLibs . libBuildInfo) (library pkg_descr), - include_dirs = maybe [] (includeDirs . libBuildInfo) (library pkg_descr), - c_includes = maybe [] (includes . libBuildInfo) (library pkg_descr), - package_deps = map pkgName (packageDeps lbi) - } - where - pkg_name = pkgName (package pkg_descr) - -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/Haddock.hs b/Distribution/Simple/Haddock.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Haddock.hs @@ -0,0 +1,307 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Invokes haddock to generate api documentation for libraries and optinally +-- executables in this package. Also has support for generating +-- syntax-highlighted source with HsColour and linking the haddock docs to it. + +{- 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.Haddock ( + haddock, hscolour + ) 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) +import Distribution.Simple.PreProcess (ppCpp', ppUnlit, preprocessSources, + PPSuffixHandler, runSimplePreProcessor) +import Distribution.Simple.Setup +import Distribution.Simple.InstallDirs (InstallDirTemplates(..), + PathTemplateVariable(..), + toPathTemplate, fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), hscolourPref, + haddockPref, distPref ) +import Distribution.Simple.Utils (die, warn, notice, createDirectoryIfMissingVerbose, + moduleToFilePath, findFile) + +import Distribution.Simple.Utils (rawSystemStdout) +import Distribution.Verbosity +import Language.Haskell.Extension +-- Base +import System.Directory(removeFile, doesFileExist) + +import Control.Monad (liftM, when, join) +import Data.Maybe ( isJust, catMaybes ) + +import Distribution.Compat.Directory(removeDirectoryRecursive, copyFile) +import System.FilePath((), (<.>), splitFileName, splitExtension, + replaceExtension) +import Distribution.Version + +-- -------------------------------------------------------------------------- +-- Haddock support + +haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) && not (haddockExecutables haddockFlags) = + warn (haddockVerbose 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." + +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 + + (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 + preprocessSources pkg_descr lbi False verbosity suffixes + + setupMessage verbosity "Running Haddock for" pkg_descr + + let replaceLitExts = map ( (tmpDir ) . (`replaceExtension` "hs") ) + let mockAll bi = mapM_ (mockPP ["-D__HADDOCK__"] bi tmpDir) + let showPkg = showPackageId (package pkg_descr) + let outputFlag = if haddockHoogle haddockFlags + then "--hoogle" + else "--html" + let Just version = programVersion confHaddock + let have_src_hyperlink_flags = version >= Version [0,8] [] + have_new_flags = version > Version [0,8] [] + let comp = compiler lbi + Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) + let ghcpkgFlags = if have_new_flags + then ["--ghc-pkg=" ++ programPath pkgTool] + else [] + let cssFileFlag = case haddockCss haddockFlags of + Nothing -> [] + Just cssFile -> ["--css=" ++ cssFile] + let verboseFlags = if verbosity > deafening then ["--verbose"] else [] + let allowMissingHtmlFlags = if have_new_flags + then ["--allow-missing-html"] + else [] + when (hsColour && not have_src_hyperlink_flags) $ + die "haddock --hyperlink-source requires Haddock version 0.8 or later" + let linkToHscolour = if hsColour + then ["--source-module=src/%{MODULE/./-}.html" + ,"--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) + + withLib pkg_descr () $ \lib -> do + let bi = libBuildInfo lib + inFiles <- getModulePaths lbi bi (exposedModules lib ++ otherModules bi) + mockAll bi inFiles + let prologName = distPref showPkg ++ "-haddock-prolog.txt" + prolog | null (description pkg_descr) = synopsis pkg_descr + | otherwise = description pkg_descr + subtitle | null (synopsis pkg_descr) = "" + | otherwise = ": " ++ synopsis pkg_descr + writeFile prologName (prolog ++ "\n") + let outFiles = 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, + "--package=" ++ showPkg, + "--dump-interface=" ++ haddockFile, + "--prologue=" ++ prologName] + ++ ghcpkgFlags + ++ allowMissingHtmlFlags + ++ cssFileFlag + ++ linkToHscolour + ++ packageFlags + ++ programArgs confHaddock + ++ verboseFlags + ++ outFiles + ++ map ("--hide=" ++) (otherModules bi) + ) + removeFile prologName + notice verbosity $ "Documentation created: " + ++ (haddockPref pkg_descr "index.html") + + withExe pkg_descr $ \exe -> when doExes $ do + let bi = buildInfo exe + exeTargetDir = haddockPref pkg_descr exeName exe + createDirectoryIfMissingVerbose verbosity True exeTargetDir + inFiles' <- getModulePaths lbi bi (otherModules bi) + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + let inFiles = srcMainPath : inFiles' + 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 outFiles = replaceLitExts inFiles + rawSystemProgram verbosity confHaddock + ([outputFlag, + "--odir=" ++ exeTargetDir, + "--title=" ++ exeName exe, + "--prologue=" ++ prologName] + ++ ghcpkgFlags + ++ allowMissingHtmlFlags + ++ linkToHscolour + ++ packageFlags + ++ programArgs confHaddock + ++ verboseFlags + ++ outFiles + ) + removeFile prologName + notice verbosity $ "Documentation created: " + ++ (exeTargetDir "index.html") + + removeDirectoryRecursive tmpDir + where + mockPP inputArgs bi pref file + = do let (filePref, fileName) = splitFileName file + let targetDir = pref filePref + let targetFile = targetDir fileName + let (targetFileNoext, targetFileExt) = splitExtension targetFile + 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 () + needsCpp :: BuildInfo -> Bool + needsCpp bi = CPP `elem` extensions bi + +-- -------------------------------------------------------------------------- +-- hscolour support + +hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () +hscolour pkg_descr lbi suffixes (HscolourFlags stylesheet doExes verbosity) = do + (confHscolour, _) <- requireProgram verbosity hscolourProgram + (orLaterVersion (Version [1,8] [])) (withPrograms lbi) + + createDirectoryIfMissingVerbose verbosity True $ hscolourPref pkg_descr + preprocessSources pkg_descr lbi False verbosity suffixes + + setupMessage verbosity "Running hscolour for" 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 + let modules = exposedModules lib ++ otherModules bi + inFiles <- getModulePaths lbi bi modules + flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> do + let outputDir = hscolourPref pkg_descr "src" + let outFile = outputDir replaceDot mo <.> "html" + createDirectoryIfMissingVerbose verbosity True outputDir + copyCSS outputDir + rawSystemProgram verbosity confHscolour + ["-css", "-anchor", "-o" ++ outFile, inFile] + + withExe pkg_descr $ \exe -> when doExes $ do + let bi = buildInfo exe + let modules = "Main" : otherModules bi + let outputDir = hscolourPref pkg_descr exeName exe "src" + createDirectoryIfMissingVerbose verbosity True outputDir + copyCSS outputDir + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + inFiles <- liftM (srcMainPath :) $ getModulePaths lbi bi (otherModules bi) + flip mapM_ (zip modules inFiles) $ \(mo, inFile) -> do + let outFile = outputDir replaceDot mo <.> "html" + rawSystemProgram verbosity confHscolour + ["-css", "-anchor", "-o" ++ outFile, inFile] + where copyCSS dir = case stylesheet of + Nothing -> return () + Just s -> copyFile s (dir "hscolour.css") + + +--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"]) diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -8,6 +8,7 @@ -- Stability : alpha -- Portability : portable -- +-- Build and install functionality for Hugs. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -41,8 +42,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Hugs ( - build, install, - hugsPackageDir + configure, build, install ) where import Distribution.PackageDescription @@ -50,28 +50,28 @@ withLib, Executable(..), withExe, Library(..), libModules, hcOptions, autogenModuleName ) -import Distribution.Compiler ( Compiler(..), CompilerFlavor(..) ) -import Distribution.Package ( PackageIdentifier(..) ) -import Distribution.Setup ( CopyDest(..) ) -import Distribution.PreProcess ( ppCpp ) -import Distribution.PreProcess.Unlit +import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..), Flag ) +import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, + requireProgram, rawSystemProgramConf, + ffihugsProgram, hugsProgram ) +import Distribution.Version ( Version(..), VersionRange(AnyVersion) ) +import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) +import Distribution.Simple.PreProcess.Unlit ( unlit ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), - mkLibDir, autogenModulesDir ) -import Distribution.Simple.Utils( rawSystemExit, die, - dirOf, dotToSep, moduleToFilePath, - smartCopySources, findFile ) + ( LocalBuildInfo(..), autogenModulesDir ) +import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, dotToSep, + moduleToFilePath, die, info, notice, + smartCopySources, findFile, dllExtension ) import Language.Haskell.Extension ( Extension(..) ) import Distribution.Compat.Directory - ( copyFile,createDirectoryIfMissing, - removeDirectoryRecursive ) -import Distribution.Compat.FilePath - ( joinFileName, splitFileExt, joinFileExt, - dllExtension, searchPathSeparator, - platformPath ) - + ( copyFile, removeDirectoryRecursive ) +import System.FilePath ( (), takeExtension, (<.>), + searchPathSeparator, normalise, takeDirectory ) +import Distribution.System +import Distribution.Verbosity +import Distribution.Package ( PackageIdentifier(..) ) import Data.Char ( isSpace ) import Data.Maybe ( mapMaybe ) @@ -85,52 +85,100 @@ import System.Directory ( Permissions(..), getPermissions, setPermissions ) + -- ----------------------------------------------------------------------------- +-- Configuring +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram AnyVersion + (userMaybeSpecifyPath "ffihugs" hcPath conf) + (_hugsProg, conf'') <- requireProgram verbosity hugsProgram AnyVersion conf' + + let comp = Compiler { + compilerFlavor = Hugs, + compilerId = PackageIdentifier "hugs" (Version [] []), + compilerExtensions = hugsLanguageExtensions + } + return (comp, conf'') + +-- | The flags for the supported extensions +hugsLanguageExtensions :: [(Extension, Flag)] +hugsLanguageExtensions = + [(OverlappingInstances , "+o") + ,(IncoherentInstances , "+oO") + ,(HereDocuments , "+H") + ,(TypeSynonymInstances , "-98") + ,(RecursiveDo , "-98") + ,(ParallelListComp , "-98") + ,(MultiParamTypeClasses , "-98") + ,(FunctionalDependencies , "-98") + ,(Rank2Types , "-98") + ,(PolymorphicComponents , "-98") + ,(ExistentialQuantification , "-98") + ,(ScopedTypeVariables , "-98") + ,(ImplicitParams , "-98") + ,(ExtensibleRecords , "-98") + ,(RestrictedTypeSynonyms , "-98") + ,(FlexibleContexts , "-98") + ,(FlexibleInstances , "-98") + ,(ForeignFunctionInterface , "") + ,(EmptyDataDecls , "") + ,(CPP , "") + ] + +-- ----------------------------------------------------------------------------- +-- Building + -- |Building a package for Hugs. -build :: PackageDescription -> LocalBuildInfo -> Int -> IO () -build pkg_descr lbi verbose = do - let pref = buildDir lbi +build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +build pkg_descr lbi verbosity = do + let pref = scratchDir lbi + createDirectoryIfMissingVerbose verbosity True pref withLib pkg_descr () $ \ l -> do - copyFile (autogenModulesDir lbi `joinFileName` paths_modulename) - (pref `joinFileName` paths_modulename) + copyFile (autogenModulesDir lbi paths_modulename) + (pref paths_modulename) compileBuildInfo pref [] (libModules pkg_descr) (libBuildInfo l) - withExe pkg_descr $ compileExecutable (pref `joinFileName` "programs") + withExe pkg_descr $ compileExecutable (pref "programs") where + srcDir = buildDir lbi + paths_modulename = autogenModuleName pkg_descr ++ ".hs" compileExecutable :: FilePath -> Executable -> IO () compileExecutable destDir (exe@Executable {modulePath=mainPath, buildInfo=bi}) = do let exeMods = otherModules bi srcMainFile <- findFile (hsSourceDirs bi) mainPath - let exeDir = destDir `joinFileName` exeName exe - let destMainFile = exeDir `joinFileName` hugsMainFilename exe + let exeDir = destDir exeName exe + let destMainFile = exeDir hugsMainFilename exe copyModule (CPP `elem` extensions bi) bi srcMainFile destMainFile - let destPathsFile = exeDir `joinFileName` paths_modulename - copyFile (autogenModulesDir lbi `joinFileName` paths_modulename) + let destPathsFile = exeDir paths_modulename + copyFile (autogenModulesDir lbi paths_modulename) destPathsFile compileBuildInfo exeDir (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi compileFiles bi exeDir [destMainFile, destPathsFile] - compileBuildInfo :: FilePath + compileBuildInfo :: FilePath -- ^output directory -> [FilePath] -- ^library source dirs, if building exes -> [String] -- ^Modules -> BuildInfo -> IO () compileBuildInfo destDir mLibSrcDirs mods bi = do - -- Pass 1: copy or cpp files from src directory to build directory + -- Pass 1: copy or cpp files from build directory to scratch directory let useCpp = CPP `elem` extensions bi - let srcDirs = nub $ hsSourceDirs bi ++ mLibSrcDirs - when (verbose > 3) (putStrLn $ "Source directories: " ++ show srcDirs) + let srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs + info verbosity $ "Source directories: " ++ show srcDirs flip mapM_ mods $ \ m -> do fs <- moduleToFilePath srcDirs m suffixes - if null fs then + case fs of + [] -> die ("can't find source for module " ++ m) - else do - let srcFile = head fs - let (_, ext) = splitFileExt srcFile + srcFile:_ -> do + let ext = takeExtension srcFile copyModule useCpp bi srcFile - (destDir `joinFileName` dotToSep m `joinFileExt` ext) - -- Pass 2: compile foreign stubs in build directory + (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) @@ -140,11 +188,11 @@ -- Copy or cpp a file from the source directory to the build directory. copyModule :: Bool -> BuildInfo -> FilePath -> FilePath -> IO () copyModule cppAll bi srcFile destFile = do - createDirectoryIfMissing True (dirOf destFile) + createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) (exts, opts, _) <- getOptionsFromSource srcFile let ghcOpts = hcOptions GHC opts if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do - ppCpp bi lbi srcFile destFile verbose + runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity return () else copyFile srcFile destFile @@ -153,8 +201,8 @@ compileFiles bi modDir fileList = do ffiFileList <- filterM testFFI fileList unless (null ffiFileList) $ do - when (verbose > 2) (putStrLn "Compiling FFI stubs") - mapM_ (compileFFI bi modDir) ffiFileList + notice verbosity "Compiling FFI stubs" + mapM_ (compileFFI bi modDir) ffiFileList -- Only compile FFI stubs for a file if it contains some FFI stuff testFFI :: FilePath -> IO Bool @@ -166,8 +214,7 @@ compileFFI bi modDir file = do (_, opts, file_incs) <- getOptionsFromSource file let ghcOpts = hcOptions GHC opts - let pkg_incs = ["\"" ++ inc ++ "\"" - | inc <- includes bi ++ installIncludes bi] + let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi] let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs)) let pathFlag = "-P" ++ modDir ++ [searchPathSeparator] let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs @@ -180,9 +227,8 @@ ldOptions bi ++ ["-l" ++ lib | lib <- extraLibs bi] ++ concat [["-framework", f] | f <- frameworks bi] - rawSystemExit verbose ffihugs (hugsArgs ++ file : cArgs) - - ffihugs = compilerPath (compiler lbi) + rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi) + (hugsArgs ++ file : cArgs) includeOpts :: [String] -> [String] includeOpts [] = [] @@ -193,7 +239,7 @@ getCFiles :: FilePath -> IO [String] getCFiles file = do inp <- readHaskellFile file - return [platformPath cfile | + return [normalise cfile | "{-#" : "CFILES" : rest <- map words $ lines $ stripComments True inp, last rest == "#-}", @@ -275,7 +321,7 @@ stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs - stripCommentsLevel n (c:cs) = stripCommentsLevel n cs + stripCommentsLevel n (_:cs) = stripCommentsLevel n cs stripCommentsLevel _ [] = [] copyString ('\\':c:cs) = '\\' : c : copyString cs @@ -288,68 +334,62 @@ copyPragma [] = [] -- ----------------------------------------------------------------------------- --- Install for Hugs +-- |Install for Hugs. -- For install, copy-prefix = prefix, but for copy they're different. --- The library goes in /lib/hugs/packages/ --- (i.e. /lib/hugs/packages/ on the target system). --- Each executable goes in /lib/hugs/programs/ --- (i.e. /lib/hugs/programs/ on the target system) --- with a script /bin/ pointing at --- /lib/hugs/programs/ +-- The library goes in \\/lib\/hugs\/packages\/\ +-- (i.e. \\/lib\/hugs\/packages\/\ on the target system). +-- Each executable goes in \\/lib\/hugs\/programs\/\ +-- (i.e. \\/lib\/hugs\/programs\/\ on the target system) +-- with a script \\/bin\/\ pointing at +-- \\/lib\/hugs\/programs\/\. install - :: Int -- ^verbose - -> FilePath -- ^Library install location - -> FilePath -- ^Program install location - -> FilePath -- ^Executable install location - -> FilePath -- ^Program location on target system - -> FilePath -- ^Build location + :: Verbosity -- ^verbosity + -> FilePath -- ^Library install location + -> FilePath -- ^Program install location + -> FilePath -- ^Executable install location + -> FilePath -- ^Program location on target system + -> FilePath -- ^Build location -> PackageDescription -> IO () -install verbose libDir installProgDir binDir targetProgDir buildPref pkg_descr = do - withLib pkg_descr () $ \ libInfo -> do - try $ removeDirectoryRecursive libDir - smartCopySources verbose [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes True False - let buildProgDir = buildPref `joinFileName` "programs" +install verbosity libDir installProgDir binDir targetProgDir buildPref pkg_descr = do + try $ removeDirectoryRecursive libDir + smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes True False + let buildProgDir = buildPref "programs" when (any (buildable . buildInfo) (executables pkg_descr)) $ - createDirectoryIfMissing True binDir + createDirectoryIfMissingVerbose verbosity True binDir withExe pkg_descr $ \ exe -> do - let buildDir = buildProgDir `joinFileName` exeName exe - let installDir = installProgDir `joinFileName` exeName exe - let targetDir = targetProgDir `joinFileName` exeName exe + let theBuildDir = buildProgDir exeName exe + let installDir = installProgDir exeName exe + let targetDir = targetProgDir exeName exe try $ removeDirectoryRecursive installDir - smartCopySources verbose [buildDir] installDir + smartCopySources verbosity [theBuildDir] installDir ("Main" : autogenModuleName pkg_descr : otherModules (buildInfo exe)) hugsInstallSuffixes True False - let targetName = "\"" ++ (targetDir `joinFileName` hugsMainFilename exe) ++ "\"" + 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)) -#if mingw32_HOST_OS || mingw32_TARGET_OS - let exeFile = binDir `joinFileName` exeName exe `joinFileExt` "bat" - let script = unlines [ - "@echo off", - unwords ("runhugs" : hugsOptions ++ [targetName, "%*"])] -#else - let exeFile = binDir `joinFileName` exeName exe - let script = unlines [ - "#! /bin/sh", - unwords ("runhugs" : hugsOptions ++ [targetName, "\"$@\""])] -#endif + let exeFile = case os of + Windows _ -> binDir exeName exe <.> ".bat" + _ -> binDir exeName exe + let script = case os of + Windows _ -> + let args = hugsOptions ++ [targetName, "%*"] + in unlines ["@echo off", + unwords ("runhugs" : args)] + _ -> + let args = hugsOptions ++ [targetName, "\"$@\""] + in unlines ["#! /bin/sh", + unwords ("runhugs" : args)] writeFile exeFile script perms <- getPermissions exeFile setPermissions exeFile perms { executable = True, readable = True } hugsInstallSuffixes :: [String] -hugsInstallSuffixes = ["hs", "lhs", dllExtension] - --- |Hugs library directory for a package -hugsPackageDir :: PackageDescription -> LocalBuildInfo -> FilePath -hugsPackageDir pkg_descr lbi = - mkLibDir pkg_descr lbi NoCopyDest - `joinFileName` "packages" `joinFileName` pkgName (package pkg_descr) +hugsInstallSuffixes = [".hs", ".lhs", dllExtension] -- |Filename used by Hugs for the main module of an executable. -- This is a simple filename, so that Hugs will look for any auxiliary -- modules it uses relative to the directory it's in. hugsMainFilename :: Executable -> FilePath -hugsMainFilename exe = "Main" `joinFileExt` ext - where (_, ext) = splitFileExt (modulePath exe) +hugsMainFilename exe = "Main" <.> ext + where ext = takeExtension (modulePath exe) diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -1,4 +1,11 @@ {-# 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 @@ -8,8 +15,9 @@ -- Stability : alpha -- Portability : portable -- --- Explanation: Perform the \"@.\/setup install@\" action. Move files into --- place based on the prefix argument. +-- Explanation: Perform the \"@.\/setup install@\" and \"@.\/setup +-- copy@\" actions. Move files into place based on the prefix +-- argument. {- All rights reserved. @@ -56,73 +64,115 @@ #endif #endif +import Distribution.Package (PackageIdentifier(..)) import Distribution.PackageDescription ( - PackageDescription(..), - setupMessage, hasLibs, withLib, withExe ) + PackageDescription(..), BuildInfo(..), Library(..), + hasLibs, withLib, hasExes, withExe ) import Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), mkLibDir, mkBinDir, mkDataDir, mkProgDir, mkHaddockDir) -import Distribution.Simple.Utils(copyFileVerbose, die, haddockPref, copyDirectoryRecursiveVerbose) -import Distribution.Compiler (CompilerFlavor(..), Compiler(..)) -import Distribution.Setup (CopyFlags(..), CopyDest(..)) - -import Distribution.Compat.Directory(createDirectoryIfMissing) -import Distribution.Compat.FilePath(splitFileName,joinFileName) + LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, haddockPref) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, + copyFileVerbose, die, info, notice, + copyDirectoryRecursiveVerbose) +import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..)) +import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..)) import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.JHC as JHC --- import qualified Distribution.Simple.NHC as NHC import qualified Distribution.Simple.Hugs as Hugs -import Control.Monad(when) -import Distribution.Compat.Directory(createDirectoryIfMissing, doesDirectoryExist) -import Distribution.Compat.FilePath(splitFileName,joinFileName) +import Control.Monad (when, unless) +import Distribution.Compat.Directory(doesDirectoryExist, doesFileExist) +import System.FilePath(takeDirectory, (), isAbsolute) +import Distribution.Verbosity + #ifdef DEBUG -import HUnit (Test) +import Test.HUnit (Test) #endif --- |FIX: nhc isn't implemented yet. -install :: PackageDescription - -> LocalBuildInfo - -> CopyFlags +-- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. FIX: +-- nhc isn't implemented yet. + +install :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> CopyFlags -- ^flags sent to copy or install -> IO () -install pkg_descr lbi (CopyFlags copydest verbose) = do - let dataFilesExist = not (null (dataFiles pkg_descr)) - docExists <- doesDirectoryExist haddockPref - when (verbose >= 4) - (putStrLn ("directory " ++ haddockPref ++ - " does exist: " ++ show docExists)) - when (dataFilesExist || docExists) $ do - let dataPref = mkDataDir pkg_descr lbi copydest - createDirectoryIfMissing True dataPref - flip mapM_ (dataFiles pkg_descr) $ \ file -> do - let (dir, _) = splitFileName file - createDirectoryIfMissing True (dataPref `joinFileName` dir) - copyFileVerbose verbose file (dataPref `joinFileName` file) - when docExists $ do - let targetDir = mkHaddockDir pkg_descr lbi copydest - createDirectoryIfMissing True targetDir - copyDirectoryRecursiveVerbose verbose haddockPref targetDir - -- setPermissionsRecursive [Read] targetDir +install pkg_descr lbi (CopyFlags copydest verbosity) = do + let InstallDirs { + bindir = binPref, + libdir = libPref, + dynlibdir = dynlibPref, + datadir = dataPref, + progdir = progPref, + docdir = docPref, + htmldir = htmlPref, + includedir = incPref + } = absoluteInstallDirs pkg_descr lbi copydest + docExists <- doesDirectoryExist $ haddockPref pkg_descr + info verbosity ("directory " ++ haddockPref 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) + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + copyDirectoryRecursiveVerbose verbosity (haddockPref pkg_descr) htmlPref + -- setPermissionsRecursive [Read] htmlPref + + let lfile = licenseFile pkg_descr + unless (null lfile) $ do + createDirectoryIfMissingVerbose verbosity True docPref + copyFileVerbose verbosity lfile (docPref lfile) + let buildPref = buildDir lbi - let libPref = mkLibDir pkg_descr lbi copydest - let binPref = mkBinDir pkg_descr lbi copydest - setupMessage ("Installing: " ++ libPref ++ " & " ++ binPref) pkg_descr + when (hasLibs pkg_descr) $ + notice verbosity ("Installing: " ++ libPref) + when (hasExes pkg_descr) $ + notice verbosity ("Installing: " ++ binPref) + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref + case compilerFlavor (compiler lbi) of - GHC -> do when (hasLibs pkg_descr) - (GHC.installLib verbose (withPrograms lbi) + GHC -> do withLib pkg_descr () $ \_ -> + GHC.installLib verbosity (withPrograms lbi) (withVanillaLib lbi) (withProfLib lbi) - (withGHCiLib lbi) libPref buildPref pkg_descr) - GHC.installExe verbose binPref buildPref pkg_descr - JHC -> do withLib pkg_descr () $ JHC.installLib verbose libPref buildPref pkg_descr - withExe pkg_descr $ JHC.installExe verbose binPref buildPref pkg_descr + (withGHCiLib lbi) libPref buildPref pkg_descr + withExe pkg_descr $ \_ -> + GHC.installExe verbosity binPref buildPref pkg_descr + JHC -> do withLib pkg_descr () $ JHC.installLib verbosity libPref buildPref pkg_descr + withExe pkg_descr $ JHC.installExe verbosity binPref buildPref pkg_descr Hugs -> do - let progPref = mkProgDir pkg_descr lbi copydest - let targetProgPref = mkProgDir pkg_descr lbi NoCopyDest - Hugs.install verbose libPref progPref binPref targetProgPref buildPref pkg_descr + 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") return () -- register step should be performed by caller. + +-- | Install the files listed in install-includes +installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installIncludeFiles verbosity PackageDescription{library=Just l} incdir + = do + incs <- mapM (findInc relincdirs) (installIncludes lbi) + unless (null incs) $ do + createDirectoryIfMissingVerbose verbosity True incdir + sequence_ [ copyFileVerbose verbosity path (incdir f) + | (f,path) <- incs ] + where + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + lbi = libBuildInfo l + + 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 +installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" -- ------------------------------------------------------------ -- * Testing diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/InstallDirs.hs @@ -0,0 +1,501 @@ +{-# 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 + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Definition of the 'LocalBuildInfo' data type. This is basically +-- the information that is gathered by the end of the configuration +-- step which could include package information from ghc-pkg, flags +-- the user passed to configure, and the location of tools in the +-- PATH. + +{- 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.InstallDirs ( + InstallDirs(..), haddockdir, + InstallDirTemplates(..), + defaultInstallDirs, + absoluteInstallDirs, + prefixRelativeInstallDirs, + + PathTemplate, + PathTemplateVariable(..), + toPathTemplate, + fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv, + ) where + + +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import System.FilePath ((), isPathSeparator) +#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(..)) + +#if mingw32_HOST_OS || mingw32_TARGET_OS +import Foreign +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Instalation directories + + +-- | The directories where we will install files for packages. +-- +-- We have several different directories for different types of files since +-- many systems have conventions whereby different types of files in a package +-- are installed in different direcotries. This is particularly the case on +-- unix style systems. +-- +data InstallDirs dir = InstallDirs { + prefix :: dir, + bindir :: dir, + libdir :: dir, + dynlibdir :: dir, + libexecdir :: dir, + progdir :: dir, + includedir :: dir, + datadir :: dir, + docdir :: dir, + htmldir :: dir + } deriving (Read, Show) + +-- | The installation dirctories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- convenient for the user to override the default installation directory +-- by only having to specify --prefix=... rather than overriding each +-- individually. This is done by allowing $-style variables in the dirs. +-- These are expanded by textual substituion (see 'substPathTemplate'). +-- +-- A few of these installation directories are split into two components, the +-- dir and subdir. The full installation path is formed by combining the two +-- together with @<\/>@. The reason for this is compatability with other unix +-- build systems which also support @--libdir@ and @--datadir@. We would like +-- users to be able to configure @--libdir=\/usr\/lib64@ for example but +-- because by default we want to support installing multiplve versions of +-- packages and building the same package for multiple compilers we append the +-- libdubdir 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 + } deriving (Read, Show) + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> IO InstallDirTemplates +defaultInstallDirs comp 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 + 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" + | otherwise -> "$prefix" + _other -> "$prefix" "share" + dataSubdir = "$pkgid" + docDir = case os of + Windows _ -> "$prefix" "doc" "$pkgid" + _other -> "$datadir" "doc" "$pkgid" + htmlDir = "$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 + } + +haddockdir :: InstallDirs FilePath -> PackageDescription -> FilePath +haddockdir installDirs pkg_descr = + htmldir installDirs + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- 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 +-- '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 + -> InstallDirTemplates -> InstallDirTemplates +substituteTemplates pkgId compilerId dirs = dirs' + where + dirs' = InstallDirTemplates { + -- 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] + } + -- 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] + +-- | 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 + -> 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 + } + 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 + +-- | 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 + -> 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 + } + where + -- 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] + } + -- 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 + 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 + +-- | An abstract path, posibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +-- +newtype PathTemplate = PathTemplate [PathComponent] + +data PathComponent = + Ordinary FilePath + | Variable PathTemplateVariable + +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 + | 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@ + | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ + deriving Eq + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +-- +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate = PathTemplate . read + +-- | Convert back to a path, ingoring any remaining vars +-- +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate cs) = concat [ c | Ordinary c <- cs ] + +substPathTemplate :: [(PathTemplateVariable, PathTemplate)] + -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + + where subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv :: PackageIdentifier -> PackageIdentifier + -> [(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)] + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +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 PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + +instance Read PathTemplateVariable where + readsPrec _ s = + take 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s ] + where vars = [("prefix", PrefixVar) + ,("bindir", BinDirVar) + ,("libdir", LibDirVar) + ,("libsubdir", LibSubdirVar) + ,("datadir", DataDirVar) + ,("datasubdir", DataSubdirVar) + ,("docdir", DocDirVar) + ,("pkgid", PkgIdVar) + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar)] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$':show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we colapse multiple $ symbols here + readsPrec _ = lex0 + where lex0 [] = [] + lex0 ('$':'$':s') = lex0 ('$':s') + lex0 ('$':s') = case [ (Variable var, s'') + | (var, s'') <- reads s' ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$':'$':s) = lex1 acc ('$':s) + lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] + lex1 acc (c:s) = lex1 (c:acc) s + readList [] = [([],"")] + readList s = [ (component:components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#if mingw32_HOST_OS || mingw32_TARGET_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) + +#if mingw32_HOST_OS || mingw32_TARGET_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = +# if __HUGS__ + return Nothing +# else + allocaBytes long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCString pPath; return (Just s) + where + long_path_size = 1024 +# endif + +csidl_PROGRAM_FILES, csidl_PROGRAM_FILES_COMMON :: CInt +csidl_PROGRAM_FILES = 0x0026 +csidl_PROGRAM_FILES_COMMON = 0x002b + +foreign import stdcall unsafe "shlobj.h SHGetFolderPathA" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CString + -> IO CInt +#endif + +#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) +-- Compat: this function only appears in FilePath > 1.0 +-- (which at the time of writing is unreleased) +dropDrive :: FilePath -> FilePath +dropDrive (c:cs) | isPathSeparator c = cs +dropDrive (_:':':c:cs) | isWindows + && isPathSeparator c = cs -- path with drive letter +dropDrive (_:':':cs) | isWindows = cs +dropDrive cs = cs + +isWindows :: Bool +isWindows = case os 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 @@ -7,6 +7,7 @@ -- Stability : alpha -- Portability : portable -- +-- Build and install functionality for the JHC compiler. {- Copyright (c) 2003-2005, Isaac Jones All rights reserved. @@ -40,7 +41,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.JHC ( - build, installLib, installExe + configure, getInstalledPackages, build, installLib, installExe ) where import Distribution.PackageDescription @@ -51,48 +52,95 @@ import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), autogenModulesDir ) -import Distribution.Compiler ( Compiler(..), CompilerFlavor(..), - extensionsToJHCFlag ) -import Distribution.Package ( showPackageId ) -import Distribution.Simple.Utils( rawSystemExit, copyFileVerbose ) -import Distribution.Compat.FilePath - ( joinFileName, exeExtension ) -import Distribution.Compat.Directory - ( createDirectoryIfMissing ) +import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..), Flag, + PackageDB, 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 System.FilePath ( () ) +import Distribution.Verbosity +import Distribution.Compat.ReadP + ( readP_to_S, many, skipSpaces ) -import Control.Monad ( when ) import Data.List ( nub, intersperse ) +import Data.Char ( isSpace ) + -- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (jhcProg, conf') <- requireProgram verbosity jhcProgram AnyVersion + (userMaybeSpecifyPath "jhc" hcPath conf) + + let Just version = programVersion jhcProg + comp = Compiler { + compilerFlavor = JHC, + compilerId = PackageIdentifier "jhc" version, + compilerExtensions = jhcLanguageExtensions + } + return (comp, conf') + +-- | The flags for the supported extensions +jhcLanguageExtensions :: [(Extension, Flag)] +jhcLanguageExtensions = + [(TypeSynonymInstances , "") + ,(ForeignFunctionInterface , "") + ,(NoImplicitPrelude , "--noprelude") + ,(CPP , "-fcpp") + ] + +getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration + -> IO [PackageIdentifier] +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 + _ -> die "cannot parse package list" + where + pCheck :: [(a, [Char])] -> [a] + pCheck rs = [ r | (r,s) <- rs, all isSpace s ] + +-- ----------------------------------------------------------------------------- -- Building -- | Building a package for JHC. -- Currently C source files are not supported. -build :: PackageDescription -> LocalBuildInfo -> Int -> IO () -build pkg_descr lbi verbose = do - let jhcPath = compilerPath (compiler lbi) +build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +build pkg_descr lbi verbosity = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) withLib pkg_descr () $ \lib -> do - when (verbose > 3) (putStrLn "Building library...") + info verbosity "Building library..." let libBi = libBuildInfo lib - let args = constructJHCCmdLine lbi libBi (buildDir lbi) verbose - rawSystemExit verbose jhcPath (["-c"] ++ args ++ libModules pkg_descr) + let args = constructJHCCmdLine lbi libBi (buildDir lbi) verbosity + rawSystemProgram verbosity jhcProg (["-c"] ++ args ++ libModules pkg_descr) let pkgid = showPackageId (package pkg_descr) - pfile = buildDir lbi `joinFileName` "jhc-pkg.conf" - hlfile= buildDir lbi `joinFileName` (pkgid ++ ".hl") + pfile = buildDir lbi "jhc-pkg.conf" + hlfile= buildDir lbi (pkgid ++ ".hl") writeFile pfile $ jhcPkgConf pkg_descr - rawSystemExit verbose jhcPath ["--build-hl="++pfile, "-o", hlfile] + rawSystemProgram verbosity jhcProg ["--build-hl="++pfile, "-o", hlfile] withExe pkg_descr $ \exe -> do - when (verbose > 3) (putStrLn ("Building executable "++exeName exe)) + info verbosity ("Building executable "++exeName exe) let exeBi = buildInfo exe - let out = buildDir lbi `joinFileName` exeName exe - let args = constructJHCCmdLine lbi exeBi (buildDir lbi) verbose - rawSystemExit verbose jhcPath (["-o",out] ++ args ++ [modulePath exe]) + let out = buildDir lbi exeName exe + let args = constructJHCCmdLine lbi exeBi (buildDir lbi) verbosity + rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) -constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath -> Int -> [String] -constructJHCCmdLine lbi bi odir verbose = - (if verbose > 4 then ["-v"] else []) - ++ snd (extensionsToJHCFlag (extensions bi)) +constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath -> Verbosity -> [String] +constructJHCCmdLine lbi bi _odir verbosity = + (if verbosity >= deafening then ["-v"] else []) + ++ extensionsToFlags (compiler lbi) (extensions bi) ++ hcOptions JHC (options bi) ++ ["--noauto","-i-"] ++ ["-i", autogenModulesDir lbi] @@ -109,15 +157,16 @@ ,"exposed-modules: " ++ (comma id (exposedModules lib)) ,"hidden-modules: " ++ (comma id (otherModules $ libBuildInfo lib)) ] - -installLib :: Int -> FilePath -> FilePath -> PackageDescription -> Library -> IO () -installLib verb dest build pkg_descr _ = do + +installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () +installLib verb dest build_dir pkg_descr _ = do let p = showPackageId (package pkg_descr)++".hl" - createDirectoryIfMissing True dest - copyFileVerbose verb (joinFileName build p) (joinFileName dest p) + createDirectoryIfMissingVerbose verb True dest + copyFileVerbose verb (build_dir p) (dest p) -installExe :: Int -> FilePath -> FilePath -> PackageDescription -> Executable -> IO () -installExe verb dest build pkg_descr exe = do - let out = exeName exe `joinFileName` exeExtension - createDirectoryIfMissing True dest - copyFileVerbose verb (joinFileName build out) (joinFileName dest out) +installExe :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Executable -> IO () +installExe verb dest build_dir _ exe = do + let out = exeName exe exeExtension + createDirectoryIfMissingVerbose verb True dest + copyFileVerbose verb (build_dir out) (dest out) + diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -8,7 +8,11 @@ -- Stability : alpha -- Portability : portable -- --- Definition of the LocalBuildInfo data type. +-- Definition of the 'LocalBuildInfo' data type. This is basically +-- the information that is gathered by the end of the configuration +-- step which could include package information from ghc-pkg, flags +-- the user passed to configure, and the location of tools in the +-- PATH. {- All rights reserved. @@ -42,54 +46,40 @@ module Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), - default_prefix, - default_bindir, - default_libdir, - default_libsubdir, - default_libexecdir, - default_datadir, - default_datasubdir, - mkLibDir, mkLibDirRel, mkBinDir, mkBinDirRel, mkLibexecDir, mkLibexecDirRel, mkDataDir, mkDataDirRel, mkHaddockDir, mkProgDir, - absolutePath, prefixRelPath, - substDir, - distPref, srcPref, autogenModulesDir, mkIncludeDir + -- * Installation directories + module Distribution.Simple.InstallDirs, + absoluteInstallDirs, prefixRelativeInstallDirs, + -- ** Deprecated install dir functions + mkLibDir, mkBinDir, mkLibexecDir, mkDataDir, + -- * Build directories + distPref, srcPref, + hscolourPref, haddockPref, + autogenModulesDir ) where -import Distribution.Program (ProgramConfiguration) +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs) +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(..), showPackageId) -import Distribution.Compiler (Compiler(..), CompilerFlavor(..), showCompilerId) -import Distribution.Setup (CopyDest(..)) -import Distribution.Compat.FilePath -#if mingw32_HOST_OS || mingw32_TARGET_OS -import Data.Maybe (fromMaybe) -import Distribution.PackageDescription (hasLibs) -import Foreign -import Foreign.C -#endif +import Distribution.Package (PackageIdentifier(..)) +import Distribution.Simple.Compiler (Compiler(..), PackageDB) +import System.FilePath (FilePath, ()) --- |Data cached after configuration step. +-- |Data cached after configuration step. See also +-- 'Distribution.Setup.ConfigFlags'. data LocalBuildInfo = LocalBuildInfo { - prefix :: FilePath, - -- ^ The installation directory (eg. @/usr/local@, or - -- @C:/Program Files/foo-1.2@ on Windows. - bindir :: FilePath, - -- ^ The bin directory - libdir :: FilePath, - -- ^ The lib directory - libsubdir :: FilePath, - -- ^ Subdirectory of libdir into which libraries are installed - libexecdir :: FilePath, - -- ^ The lib directory - datadir :: FilePath, - -- ^ The data directory - datasubdir :: FilePath, - -- ^ Subdirectory of datadir into which data files are installed + installDirTemplates :: InstallDirTemplates, + -- ^ The installation directories for the various differnt + -- kinds of files compiler :: Compiler, -- ^ The compiler we're building with buildDir :: FilePath, - -- ^ Where to put the result of building. + -- ^ Where to build the package. + scratchDir :: FilePath, + -- ^ Where to put the result of the Hugs build. packageDeps :: [PackageIdentifier], -- ^ Which packages we depend on, /exactly/. -- The 'Distribution.PackageDescription.PackageDescription' @@ -97,19 +87,19 @@ -- 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. - withPrograms :: ProgramConfiguration, -- location and args for all programs - userConf :: Bool, -- ^Was this package configured with --user? - withHappy :: Maybe FilePath, -- ^Might be the location of the Happy executable. - withAlex :: Maybe FilePath, -- ^Might be the location of the Alex executable. - withHsc2hs :: Maybe FilePath, -- ^Might be the location of the Hsc2hs executable. - withC2hs :: Maybe FilePath, -- ^Might be the location of the C2hs executable. - withCpphs :: Maybe FilePath, -- ^Might be the location of the Cpphs executable. - withGreencard :: Maybe FilePath, -- ^Might be the location of the GreenCard executable. + localPkgDescr :: PackageDescription, + -- ^ The resolved package description, that does not contain + -- any conditionals. + withPrograms :: ProgramConfiguration, -- ^Location and args for all programs + withPackageDB :: PackageDB, -- ^What package database to use, global\/user withVanillaLib:: Bool, -- ^Whether to build normal libs. 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). 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 + } deriving (Read, Show) -- ------------------------------------------------------------ @@ -120,205 +110,60 @@ distPref = "dist" srcPref :: FilePath -srcPref = distPref `joinFileName` "src" +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 `joinFileName` "autogen" - --- |The place where install-includes are installed, relative to libdir -mkIncludeDir :: FilePath -> FilePath -mkIncludeDir = (`joinFileName` "include") +autogenModulesDir lbi = buildDir lbi "autogen" -- ----------------------------------------------------------------------------- --- Default directories - -{- -The defaults are as follows: - -Windows: - prefix = C:\Program Files - bindir = $prefix\$pkgid - libdir = $prefix\Haskell - libsubdir = $pkgid\$compiler - datadir = $prefix (for an executable) - = $prefix\Common Files (for a library) - datasubdir = $pkgid - libexecdir = $prefix\$pkgid - -Unix: - prefix = /usr/local - bindir = $prefix/bin - libdir = $prefix/lib/$pkgid/$compiler - libsubdir = $pkgid/$compiler - datadir = $prefix/share/$pkgid - datasubdir = $pkgid - libexecdir = $prefix/libexec --} - -default_prefix :: IO String -#if mingw32_HOST_OS || mingw32_TARGET_OS -# if __HUGS__ -default_prefix = return "C:\\Program Files" -# else -default_prefix = getProgramFilesDir -# endif -#else -default_prefix = return "/usr/local" -#endif - -#if mingw32_HOST_OS || mingw32_TARGET_OS -getProgramFilesDir = do - m <- shGetFolderPath csidl_PROGRAM_FILES - return (fromMaybe "C:\\Program Files" m) - -getCommonFilesDir = do - m <- shGetFolderPath csidl_PROGRAM_FILES_COMMON - case m of - Nothing -> getProgramFilesDir - Just s -> return s - -shGetFolderPath id = - allocaBytes long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr id nullPtr 0 pPath - if (r /= 0) - then return Nothing - else do s <- peekCString pPath; return (Just s) - where - long_path_size = 1024 - -csidl_PROGRAM_FILES = 0x0026 :: CInt -csidl_PROGRAM_FILES_COMMON = 0x002b :: CInt - -foreign import stdcall unsafe "shlobj.h SHGetFolderPathA" - c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CString - -> IO CInt -#endif - -default_bindir :: FilePath -default_bindir = "$prefix" `joinFileName` -#if mingw32_HOST_OS || mingw32_TARGET_OS - "Haskell" `joinFileName` "bin" -#else - "bin" -#endif - -default_libdir :: Compiler -> FilePath -default_libdir hc = "$prefix" `joinFileName` -#if mingw32_HOST_OS || mingw32_TARGET_OS - "Haskell" -#else - "lib" -#endif - -default_libsubdir :: Compiler -> FilePath -default_libsubdir hc = - case compilerFlavor hc of - Hugs -> "hugs" `joinFileName` "packages" `joinFileName` "$pkg" - JHC -> "$compiler" - _ -> "$pkgid" `joinFileName` "$compiler" +-- Wrappers for a couple functions from InstallDirs -default_libexecdir :: FilePath -default_libexecdir = "$prefix" `joinFileName` -#if mingw32_HOST_OS || mingw32_TARGET_OS - "$pkgid" -#else - "libexec" -#endif +-- |See 'InstallDirs.absoluteInstallDirs' +absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg_descr lbi copydest = + InstallDirs.absoluteInstallDirs + (package pkg_descr) + (compilerId (compiler lbi)) + copydest + (installDirTemplates lbi) -default_datadir :: PackageDescription -> IO FilePath -default_datadir pkg_descr -#if mingw32_HOST_OS || mingw32_TARGET_OS - | hasLibs pkg_descr = getCommonFilesDir - | otherwise = return ("$prefix" `joinFileName` "Haskell") -#else - = return ("$prefix" `joinFileName` "share") -#endif +-- |See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeInstallDirs :: PackageDescription -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + InstallDirs.prefixRelativeInstallDirs + (package pkg_descr) + (compilerId (compiler lbi)) + (installDirTemplates lbi) -default_datasubdir :: FilePath -default_datasubdir = "$pkgid" +-- ----------------------------------------------------------------------------- +-- Compatability aliases mkBinDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath mkBinDir pkg_descr lbi copydest = - absolutePath pkg_descr lbi copydest (bindir lbi) - -mkBinDirRel :: PackageDescription -> LocalBuildInfo -> CopyDest -> Maybe FilePath -mkBinDirRel pkg_descr lbi copydest = - prefixRelPath pkg_descr lbi copydest (bindir lbi) + bindir (absoluteInstallDirs pkg_descr lbi copydest) +{-# DEPRECATED mkBinDir "use bindir :: InstallDirs -> FilePath" #-} mkLibDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath mkLibDir pkg_descr lbi copydest = - absolutePath pkg_descr lbi copydest (libdir lbi `joinFileName` libsubdir lbi) - -mkLibDirRel :: PackageDescription -> LocalBuildInfo -> CopyDest -> Maybe FilePath -mkLibDirRel pkg_descr lbi copydest = - prefixRelPath pkg_descr lbi copydest (libdir lbi `joinFileName` libsubdir lbi) + libdir (absoluteInstallDirs pkg_descr lbi copydest) +{-# DEPRECATED mkLibDir "use libdir :: InstallDirs -> FilePath" #-} mkLibexecDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath mkLibexecDir pkg_descr lbi copydest = - absolutePath pkg_descr lbi copydest (libexecdir lbi) - -mkLibexecDirRel :: PackageDescription -> LocalBuildInfo -> CopyDest -> Maybe FilePath -mkLibexecDirRel pkg_descr lbi copydest = - prefixRelPath pkg_descr lbi copydest (libexecdir lbi) + libexecdir (absoluteInstallDirs pkg_descr lbi copydest) +{-# DEPRECATED mkLibexecDir "use libexecdir :: InstallDirs -> FilePath" #-} mkDataDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath mkDataDir pkg_descr lbi copydest = - absolutePath pkg_descr lbi copydest (datadir lbi `joinFileName` datasubdir lbi) - -mkDataDirRel :: PackageDescription -> LocalBuildInfo -> CopyDest -> Maybe FilePath -mkDataDirRel pkg_descr lbi copydest = - prefixRelPath pkg_descr lbi copydest (datadir lbi `joinFileName` datasubdir lbi) - -mkHaddockDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath -mkHaddockDir pkg_descr lbi copydest = - foldl1 joinPaths [mkDataDir pkg_descr lbi copydest, "doc", "html"] - - - --- | Directory for program modules (Hugs only). -mkProgDir :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath -mkProgDir pkg_descr lbi copydest = - absolutePath pkg_descr lbi copydest (libdir lbi) `joinFileName` - "hugs" `joinFileName` "programs" - -prefixRelPath :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath - -> Maybe FilePath -prefixRelPath pkg_descr lbi0 copydest ('$':'p':'r':'e':'f':'i':'x':s) = Just $ - case s of - (c:s) | isPathSeparator c -> substDir pkg_descr lbi s - s -> substDir pkg_descr lbi s - where - lbi = case copydest of - CopyPrefix d -> lbi0{prefix=d} - _otherwise -> lbi0 -prefixRelPath pkg_descr lbi copydest s = Nothing - -absolutePath :: PackageDescription -> LocalBuildInfo -> CopyDest -> FilePath - -> FilePath -absolutePath pkg_descr lbi copydest s = - case copydest of - NoCopyDest -> substDir pkg_descr lbi s - CopyPrefix d -> substDir pkg_descr lbi{prefix=d} s - CopyTo p -> p `joinFileName` (dropAbsolutePrefix (substDir pkg_descr lbi s)) - -substDir :: PackageDescription -> LocalBuildInfo -> String -> String -substDir pkg_descr lbi s = loop s - where - loop "" = "" - loop ('$':'p':'r':'e':'f':'i':'x':s) - = prefix lbi ++ loop s - loop ('$':'c':'o':'m':'p':'i':'l':'e':'r':s) - = showCompilerId (compiler lbi) ++ loop s - loop ('$':'p':'k':'g':'i':'d':s) - = showPackageId (package pkg_descr) ++ loop s - loop ('$':'p':'k':'g':s) - = pkgName (package pkg_descr) ++ loop s - loop ('$':'v':'e':'r':'s':'i':'o':'n':s) - = show (pkgVersion (package pkg_descr)) ++ loop s - loop ('$':'$':s) = '$' : loop s - loop (c:s) = c : loop s + 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 @@ -39,28 +39,71 @@ (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.NHC ( - build{-, install -} - ) where +module Distribution.Simple.NHC + ( configure + , build +{-, install -} + ) where import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), libModules, hcOptions) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Utils( rawSystemExit ) -import Distribution.Compiler ( Compiler(..), CompilerFlavor(..), - extensionsToNHCFlag ) +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) ) +import Distribution.Verbosity + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_hmakeProg, conf') <- requireProgram verbosity hmakeProgram AnyVersion + (userMaybeSpecifyPath "hmake" hcPath conf) + + let comp = Compiler { + compilerFlavor = NHC, + compilerId = error "TODO: nhc98 compilerId", --PackageIdentifier "nhc98" version + compilerExtensions = nhcLanguageExtensions + } + return (comp, conf') + +-- | The flags for the supported extensions +nhcLanguageExtensions :: [(Extension, Flag)] +nhcLanguageExtensions = + -- NHC doesn't enforce the monomorphism restriction at all. + [(NoMonomorphismRestriction, "") + ,(ForeignFunctionInterface, "") + ,(ExistentialQuantification, "") + ,(EmptyDataDecls, "") + ,(NamedFieldPuns, "-puns") + ,(CPP, "-cpp") + ] + +-- ----------------------------------------------------------------------------- +-- Building + -- |FIX: For now, the target must contain a main module. Not used -- ATM. Re-add later. -build :: PackageDescription -> LocalBuildInfo -> Int -> IO () -build pkg_descr lbi verbose = do +build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +build pkg_descr lbi verbosity = -- Unsupported extensions have already been checked by configure - let flags = snd $ extensionsToNHCFlag (maybe [] (extensions . libBuildInfo) (library pkg_descr)) - rawSystemExit verbose (compilerPath (compiler lbi)) - (["-nhc98"] + 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)) + ++ maybe [] (hcOptions NHC . options . libBuildInfo) + (library pkg_descr) + ++ libModules pkg_descr) diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/PreProcess.hs @@ -0,0 +1,464 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- +-- PreProcessors are programs or functions which input a filename and +-- output a Haskell file. The general form of a preprocessor is input +-- Foo.pp and output Foo.hs (where /pp/ is a unique extension that +-- tells us which preprocessor to use eg. gc, ly, cpphs, x, y, etc.). +-- Once a PreProcessor has been added to Cabal, either here or with +-- 'Distribution.Simple.UserHooks', if Cabal finds a Foo.pp, it'll run the given +-- preprocessor which should output a Foo.hs. + +{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace +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.PreProcess (preprocessSources, knownSuffixHandlers, + ppSuffixes, PPSuffixHandler, PreProcessor, + runSimplePreProcessor, + removePreprocessed, removePreprocessedPackage, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit + ) + where + + +import Distribution.Simple.PreProcess.Unlit (unlit) +import Distribution.PackageDescription (setupMessage, PackageDescription(..), + BuildInfo(..), Executable(..), withExe, + Library(..), withLib, libModules) +import Distribution.Package (showPackageId) +import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..), compilerVersion) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, die, + moduleToFilePath, moduleToFilePath2) +import Distribution.Simple.Program (Program(..), ConfiguredProgram(..), + lookupProgram, programPath, + rawSystemProgramConf, rawSystemProgram, + greencardProgram, cpphsProgram, hsc2hsProgram, + c2hsProgram, happyProgram, alexProgram, + haddockProgram, ghcProgram) +import Distribution.Version (Version(..)) +import Distribution.Verbosity + +import Control.Monad (when, unless, join) +import Data.Maybe (fromMaybe) +import Data.List (nub) +import System.Directory (removeFile, getModificationTime) +import System.Info (os, arch) +import System.FilePath (splitExtension, dropExtensions, (), (<.>), + takeDirectory, normalise) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other genereated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the genereated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use "-I .", instead we use +-- "-I dist\/build" (or whatever dist dir has been set by the user) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +-- +data PreProcessor = PreProcessor { + + -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- inlcuded into a source tarball. + platformIndependent :: Bool, + + -- TODO: deal with pre-processors that have implementaion dependent output + -- eg alex and happy have --ghc flags. However we can't really inlcude + -- ghc-specific code into supposedly portable source tarballs. + + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) -> Verbosity -> IO () +mkSimplePreProcessor simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity + where inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) + +-- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain +-- a Haskell source file for each module. +preprocessSources :: PackageDescription + -> LocalBuildInfo + -> Bool -- ^ Build for SDist + -> Verbosity -- ^ verbosity + -> [PPSuffixHandler] -- ^ preprocessors to try + -> IO () + +preprocessSources pkg_descr lbi forSDist verbosity handlers = do + withLib pkg_descr () $ \ lib -> do + setupMessage verbosity "Preprocessing library" pkg_descr + let bi = libBuildInfo lib + let biHandlers = localHandlers bi + sequence_ [ preprocessModule (hsSourceDirs bi) (buildDir lbi) forSDist + modu verbosity builtinSuffixes biHandlers + | modu <- libModules pkg_descr] + unless (null (executables pkg_descr)) $ + setupMessage verbosity "Preprocessing executables for" 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 + modu verbosity builtinSuffixes biHandlers + | modu <- otherModules bi] + preprocessModule (hsSourceDirs bi) exeDir forSDist + (dropExtensions (modulePath theExe)) + verbosity builtinSuffixes biHandlers + where hc = compilerFlavor (compiler lbi) + builtinSuffixes + | hc == NHC = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + +-- |Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessModule + :: [FilePath] -- ^source directories + -> FilePath -- ^build directory + -> Bool -- ^preprocess for sdist + -> String -- ^module name + -> Verbosity -- ^verbosity + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> IO () +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) + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + [] -> do bsrcFiles <- moduleToFilePath searchLoc modu builtinSuffixes + case bsrcFiles of + [] -> die ("can't find source for " ++ modu ++ " in " ++ show searchLoc) + _ -> return () + -- found a pre-processable file in one of the source dirs + ((psrcLoc, psrcRelFile):_) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup (tailNotNull ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + 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 + recomp <- case ppsrcFiles of + [] -> return True + (ppsrcFile:_) -> do + btime <- getModificationTime ppsrcFile + ptime <- getModificationTime psrcFile + return (btime < ptime) + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessor pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") verbosity + + where dirName = takeDirectory + 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 +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard _ lbi + = PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor { + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> do + contents <- readFile inFile + writeFile outFile (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi + _ -> ppCpphs (cppArgs ++ extraArgs) bi lbi + + where cppArgs = sysDefines ++ getCppOptions bi lbi + sysDefines = + ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] ++ + ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] + locations = ["BUILD", "HOST"] + +ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppGhcCpp extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgram verbosity ghcProg $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else []) + ++ (if use_optP_P lbi then ["-optP-P"] else []) + ++ ["-o", outFile, inFile] + ++ extraArgs + } + where Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) + Just ghcVersion = programVersion ghcProg + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity cpphsProgram (withPrograms lbi) $ + ("-O" ++ outFile) : inFile + : "--noline" : "--strip" + : extraArgs + } + +-- Haddock versions before 0.8 choke on #line and #file pragmas. Those +-- pragmas are necessary for correct links when we preprocess. So use +-- -optP-P only if the Haddock version is prior to 0.8. +use_optP_P :: LocalBuildInfo -> Bool +use_optP_P lbi + = case lookupProgram haddockProgram (withPrograms lbi) of + Just (ConfiguredProgram { programVersion = Just version }) + | version >= Version [0,8] [] -> False + _ -> True + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi = pp + where pp = standardPP lbi hsc2hsProgram flags + flags = case fmap versionTags . join . fmap programVersion + . lookupProgram hsc2hsProgram . withPrograms $ lbi of + -- Just to make things complicated, the hsc2hs bundled with + -- ghc uses ghc as the C compiler, so to pass C flags we + -- have to use an additional layer of escaping. Grrr. + Just ["ghc"] -> + let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) + in [ "--cc=" ++ programPath ghcProg + , "--ld=" ++ programPath ghcProg ] + ++ [ "--cflag=-optc" ++ opt | opt <- ccOptions bi + ++ cppOptions bi ] + ++ [ "--cflag=" ++ opt | pkg <- packageDeps lbi + , opt <- ["-package" + ,showPackageId pkg] ] + ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi] + ++ [ "--lflag=-optl" ++ opt | opt <- getLdOptions bi ] + + _ -> [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] + ++ [ "--cflag=" ++ opt | opt <- ccOptions bi ] + ++ [ "--cflag=-I" ++ dir | dir <- includeDirs bi ] + ++ [ "--lflag=" ++ opt | opt <- getLdOptions bi ] + +getLdOptions :: BuildInfo -> [String] +getLdOptions bi = map ("-L" ++) (extraLibDirs bi) + ++ map ("-l" ++) (extraLibs bi) + ++ ldOptions bi + +ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppC2hs bi lbi + = PreProcessor { + platformIndependent = False, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> + rawSystemProgramConf verbosity c2hsProgram (withPrograms lbi) $ + ["--include=" ++ outBaseDir] + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--output-dir=" ++ outBaseDir, + "--output=" ++ outRelativeFile, + inBaseDir inRelativeFile] + } + +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = hcDefines (compiler lbi) + ++ ["-I" ++ dir | dir <- includeDirs bi] + ++ [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"] + +hcDefines :: Compiler -> [String] +hcDefines comp = + case compilerFlavor comp of + GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where version = compilerVersion comp + +-- TODO: move this into the compiler abstraction +-- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other +-- compilers. Check if that's really what they want. +versionInt :: Version -> String +versionInt (Version { versionBranch = [] }) = "1" +versionInt (Version { versionBranch = [n] }) = show n +versionInt (Version { versionBranch = n1:n2:_ }) + = show n1 ++ take 2 ('0' : show n2) + +ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHappy _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppAlex _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] diff --git a/Distribution/Simple/PreProcess/Unlit.hs b/Distribution/Simple/PreProcess/Unlit.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/PreProcess/Unlit.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : Malcolm Wallace +-- Stability : Stable +-- Portability : portable +-- +-- 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 + +import Data.Char + +data Classified = Program String | Blank | Comment + | Include Int String | Pre String + +plain :: String -> String -> String -- no unliteration +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:file:_) | all isDigit line + -> Include (read line) file + _ -> Pre x + ) : classify xs +classify (x:xs) | all isSpace x = Blank:classify xs +classify (_:xs) = Comment:classify xs + +unclassify :: Classified -> String +unclassify (Program s) = s +unclassify (Pre s) = '#':s +unclassify (Include i f) = '#':' ':show i ++ ' ':f +unclassify Blank = "" +unclassify Comment = "" + +-- | '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) + +-- 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 _ _ _ [] = [] + +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" + + +-- 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' (c:s) acc = lines' s (acc . (c:)) + diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program.hs @@ -0,0 +1,628 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC, Hugs +-- +-- Explanation: A program is basically a name, a location, and some +-- arguments. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program ( + -- * Program and functions for constructing them + Program(..) + , simpleProgram + , findProgramOnPath + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram(..) + , programPath + , ProgArg + , ProgramLocation(..) + , rawSystemProgram + , rawSystemProgramStdout + + -- * The collection of unconfigured and configured progams + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramConfiguration + , emptyProgramConfiguration + , defaultProgramConfiguration + , addKnownProgram + , lookupKnownProgram + , knownPrograms + , userSpecifyPath + , userMaybeSpecifyPath + , userSpecifyArgs + , lookupProgram + , updateProgram + , configureAllKnownPrograms + , requireProgram + , rawSystemProgramConf + , rawSystemProgramStdoutConf + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , hugsProgram + , ffihugsProgram + , ranlibProgram + , arProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pfesetupProgram + , pkgConfigProgram + ) where + +import qualified Distribution.Compat.Map as Map +import Distribution.Compat.Directory (findExecutable) +import Distribution.Compat.TempFile (withTempFile) +import Distribution.Simple.Utils (die, debug, warn, rawSystemExit, + rawSystemStdout, rawSystemStdout') +import Distribution.Version (Version(..), readVersion, showVersion, + VersionRange(..), withinRange, showVersionRange) +import Distribution.Verbosity +import System.Directory (doesFileExist, removeFile) +import System.FilePath (dropExtension) +import System.IO.Error (try) +import Control.Monad (join, foldM) +import Control.Exception as Exception (catch) + +-- | Represents a program which can be configured. +data Program = Program { + -- | The simple name of the program, eg. ghc + programName :: String, + + -- | A function to search for the program if it's location was not + -- specified by the user. Usually this will just be a + programFindLocation :: Verbosity -> IO (Maybe FilePath), + + -- | Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's ok to return Nothing. + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) + } + +type ProgArg = String + +data ConfiguredProgram = ConfiguredProgram { + -- | Just the name again + programId :: String, + + -- | The version of this program, if it is known. + programVersion :: Maybe Version, + + -- | Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + programArgs :: [ProgArg], + + -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + programLocation :: ProgramLocation + } deriving (Read, Show) + +-- | Where a program was found. Also tells us whether it's specifed by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = UserSpecified { locationPath :: FilePath } + -- ^The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + | FoundOnSystem { locationPath :: FilePath } + -- ^The location of the program, as located by searching PATH. + deriving (Read, Show) + +-- ------------------------------------------------------------ +-- * Programs functions +-- ------------------------------------------------------------ + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = + Program name (findProgramOnPath name) (\_ _ -> return Nothing) + +-- | Look for a program on the path. +findProgramOnPath :: FilePath -> Verbosity -> IO (Maybe FilePath) +findProgramOnPath prog verbosity = do + debug verbosity $ "searching for " ++ prog ++ " in path." + res <- findExecutable prog + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) + return res + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +-- +findProgramVersion :: ProgArg -- ^ version args + -> (String -> String) -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = do + str <- rawSystemStdout verbosity path [versionArg] + `Exception.catch` \_ -> return "" + let version = readVersion (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 + return version + +-- ------------------------------------------------------------ +-- * Programs database +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramConfiguration = ProgramConfiguration { + unconfiguredProgs :: UnconfiguredProgs, + configuredProgs :: ConfiguredProgs + } +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + +emptyProgramConfiguration :: ProgramConfiguration +emptyProgramConfiguration = ProgramConfiguration Map.empty Map.empty + +defaultProgramConfiguration :: ProgramConfiguration +defaultProgramConfiguration = + foldl (flip addKnownProgram) emptyProgramConfiguration builtinPrograms + +-- internal helpers: +updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramConfiguration -> ProgramConfiguration +updateUnconfiguredProgs update conf = + conf { unconfiguredProgs = update (unconfiguredProgs conf) } +updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramConfiguration -> ProgramConfiguration +updateConfiguredProgs update conf = + conf { configuredProgs = update (configuredProgs conf) } + +-- Read & Show instances are based on listToFM +-- Note that we only serialise the configured part of the database, this is +-- because we don't need the unconfigured part after the configure stage, and +-- additionally because we cannot read/show 'Program' as it contains functions. +instance Show ProgramConfiguration where + show = show . Map.toAscList . configuredProgs + +instance Read ProgramConfiguration where + readsPrec p s = + [ (emptyProgramConfiguration { configuredProgs = Map.fromList s' }, r) + | (s', r) <- readsPrec p s ] + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +addKnownProgram :: Program -> ProgramConfiguration -> ProgramConfiguration +addKnownProgram prog = updateUnconfiguredProgs $ + Map.insert (programName prog) (prog, Nothing, []) + +lookupKnownProgram :: String -> ProgramConfiguration -> Maybe Program +lookupKnownProgram name = + fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs + +knownPrograms :: ProgramConfiguration -> [(Program, Maybe ConfiguredProgram)] +knownPrograms conf = + [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) + , let p' = Map.lookup (programName p) (configuredProgs conf) ] + +-- |User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +userSpecifyPath :: String -- ^Program name + -> FilePath -- ^user-specified path to the program + -> ProgramConfiguration -> ProgramConfiguration +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) + +userMaybeSpecifyPath :: String -> Maybe FilePath + -> ProgramConfiguration -> ProgramConfiguration +userMaybeSpecifyPath _ Nothing conf = conf +userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf + +-- |User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs :: String -- ^Program name + -> [ProgArg] -- ^user-specified args + -> ProgramConfiguration + -> ProgramConfiguration +userSpecifyArgs name args' = + updateUnconfiguredProgs + (flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args')) + . updateConfiguredProgs + (flip Map.update name $ + \prog -> Just prog { programArgs = programArgs prog ++ args' }) + +userSpecifiedPath :: Program -> ProgramConfiguration -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs + +userSpecifiedArgs :: Program -> ProgramConfiguration -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramConfiguration -> Maybe ConfiguredProgram +lookupProgram prog = Map.lookup (programName prog) . configuredProgs + +-- | Update a configured program in the database. +updateProgram :: ConfiguredProgram -> ProgramConfiguration + -> ProgramConfiguration +updateProgram prog = updateConfiguredProgs $ + Map.insert (programId prog) prog + +-- --------------------------- +-- Configuring known programs + +-- | Try to configure a specific program. If the program is already included in +-- the colleciton of unconfigured programs then we use any user-supplied +-- location and arguments. If the program gets configured sucessfully it gets +-- added to the configured collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- The reason for it not being a failure at this stage is that we don't know up +-- front all the programs we will need, so we try to configure them all. +-- To verify that a program was actually sucessfully configured use +-- 'requireProgram'. +-- +configureProgram :: Verbosity + -> Program + -> ProgramConfiguration + -> IO ProgramConfiguration +configureProgram verbosity prog conf = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog conf of + Nothing -> programFindLocation prog verbosity + >>= return . fmap FoundOnSystem + Just path -> do + absolute <- doesFileExist path + if absolute + then return (Just (UserSpecified path)) + else findProgramOnPath path verbosity + >>= maybe (die notFound) (return . Just . UserSpecified) + where notFound = "Cannot find " ++ name ++ " at " + ++ path ++ " or on the path" + case maybeLocation of + Nothing -> return conf + Just location -> do + version <- programFindVersion prog verbosity (locationPath location) + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programArgs = userSpecifiedArgs prog conf, + programLocation = location + } + return (updateConfiguredProgs (Map.insert name configuredProg) conf) + +-- | Try to configure all the known programs that have not yet been configured. +configureAllKnownPrograms :: Verbosity + -> ProgramConfiguration + -> IO ProgramConfiguration +configureAllKnownPrograms verbosity conf = + foldM (flip (configureProgram verbosity)) conf + [ prog | (prog,_,_) <- Map.elems (unconfiguredProgs conf + `Map.difference` configuredProgs conf) ] + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the version of the program number is suitable. +-- For example 'AnyVersion' or @'orLaterVersion' ('Version' [1,0] [])@ +-- +-- It raises an exception if the program could not be configured or the version +-- is unsuitable, otherwise it returns the configured program. +requireProgram :: Verbosity -> Program -> VersionRange -> ProgramConfiguration + -> IO (ConfiguredProgram, ProgramConfiguration) +requireProgram verbosity prog range conf = do + + -- If it's not already been configured, try to configure it now + conf' <- case lookupProgram prog conf of + Nothing -> configureProgram verbosity prog conf + Just _ -> return conf + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg + | range == AnyVersion -> return (configuredProg, conf') + Just configuredProg@ConfiguredProgram { programLocation = location } -> + case programVersion configuredProg of + Just version + | withinRange version range -> return (configuredProg, conf') + | otherwise -> die (badVersion version location) + Nothing -> die (noVersion location) + + where notFound = programName prog ++ versionRequirement + ++ " 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 + noVersion l = programName prog ++ versionRequirement + ++ " is required but the version of " + ++ locationPath l ++ " could not be determined." + versionRequirement + | range == AnyVersion = "" + | otherwise = " version " ++ showVersionRange range + +-- ------------------------------------------------------------ +-- * Running programs +-- ------------------------------------------------------------ + +-- | Runs the given configured program. +rawSystemProgram :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +rawSystemProgram verbosity prog extraArgs + = rawSystemExit verbosity (programPath prog) (programArgs prog ++ extraArgs) + +-- | Runs the given configured program and gets the output. +rawSystemProgramStdout :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +rawSystemProgramStdout verbosity prog extraArgs + = rawSystemStdout verbosity (programPath prog) (programArgs prog ++ extraArgs) + +-- | Looks up the given program in the program configuration and runs it. +rawSystemProgramConf :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramConfiguration -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +rawSystemProgramConf verbosity prog programConf extraArgs = + case lookupProgram prog programConf of + Nothing -> die ("The program " ++ programName prog ++ " is required but it could not be found") + Just configuredProg -> rawSystemProgram verbosity configuredProg extraArgs + +-- | Looks up the given program in the program configuration and runs it. +rawSystemProgramStdoutConf :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramConfiguration -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +rawSystemProgramStdoutConf verbosity prog programConf extraArgs = + case lookupProgram prog programConf of + Nothing -> die ("The program " ++ programName prog ++ " is required but it could not be found") + Just configuredProg -> rawSystemProgramStdout verbosity configuredProg extraArgs + +-- ------------------------------------------------------------ +-- * Known programs +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ + -- compilers and related progs + ghcProgram + , ghcPkgProgram + , hugsProgram + , ffihugsProgram + , nhcProgram + , hmakeProgram + , jhcProgram + -- preprocessors + , hscolourProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + , pfesetupProgram + -- platform toolchain + , ranlibProgram + , arProgram + , ldProgram + , tarProgram + -- configuration tools + , pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = (simpleProgram "ghc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +ghcPkgProgram :: Program +ghcPkgProgram = (simpleProgram "ghc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +nhcProgram :: Program +nhcProgram = simpleProgram "nhc98" + +hmakeProgram :: Program +hmakeProgram = (simpleProgram "hmake") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + (_:ver:_) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = (simpleProgram "jhc") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + (_:ver:_) -> ver + _ -> "" + } + +-- AArgh! Finding the version of hugs or ffihugs is almost impossible. +hugsProgram :: Program +hugsProgram = simpleProgram "hugs" + +ffihugsProgram :: Program +ffihugsProgram = simpleProgram "ffihugs" + +happyProgram :: Program +happyProgram = (simpleProgram "happy") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = (simpleProgram "alex") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + + +ranlibProgram :: Program +ranlibProgram = simpleProgram "ranlib" + +arProgram :: Program +arProgram = simpleProgram "ar" + +hsc2hsProgram :: Program +hsc2hsProgram = (simpleProgram "hsc2hs") { + programFindVersion = \verbosity path -> do + maybeVersion <- findProgramVersion "--version" (\str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_:_:ver:_) -> ver + _ -> "") verbosity path + + -- It turns out that it's important to know if hsc2hs is using gcc or ghc + -- as it's C compiler since this affects how we escape C options. + -- So here's a cunning hack, we make a temp .hsc file and call: + -- hsch2s tmp.hsc --cflag=--version + -- which passes --version through to ghc/gcc and we look at the result + -- to see if it was indeed ghc or not. + case maybeVersion of + Nothing -> return Nothing + Just version -> + withTempFile "." "hsc" $ \hsc -> do + writeFile hsc "" + (str, _) <- rawSystemStdout' verbosity path [hsc, "--cflag=--version"] + try $ removeFile (dropExtension hsc ++ "_hsc_make.c") + case words str of + (_:"Glorious":"Glasgow":"Haskell":_) + -> return $ Just version { versionTags = ["ghc"] } + _ -> return $ Just version + + } + +c2hsProgram :: Program +c2hsProgram = (simpleProgram "c2hs") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = (simpleProgram "cpphs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = (simpleProgram "hscolour") { + programFindLocation = findProgramOnPath "HsColour", + programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = (simpleProgram "haddock") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +greencardProgram :: Program +greencardProgram = simpleProgram "greencard" + +ldProgram :: Program +ldProgram = simpleProgram "ld" + +tarProgram :: Program +tarProgram = simpleProgram "tar" + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pfesetupProgram :: Program +pfesetupProgram = simpleProgram "pfesetup" + +pkgConfigProgram :: Program +pkgConfigProgram = (simpleProgram "pkg-config") { + programFindVersion = findProgramVersion "--version" id + } diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -47,11 +47,9 @@ unregister, writeInstalledConfig, removeInstalledConfig, - installedPkgConfigFile, - regScriptLocation, - unregScriptLocation, + removeRegScripts, #ifdef DEBUG - hunitTests + hunitTests, installedPkgConfigFile #endif ) where @@ -63,55 +61,58 @@ #endif #endif -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), mkLibDir, mkHaddockDir, - mkIncludeDir) -import Distribution.Compiler (CompilerFlavor(..), Compiler(..)) -import Distribution.Setup (RegisterFlags(..), CopyDest(..), userOverride) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), distPref, + InstallDirs(..), haddockdir, + InstallDirTemplates(..), + absoluteInstallDirs, toPathTemplate) +import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..), + compilerVersion, 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.InstalledPackageInfo (InstalledPackageInfo, showInstalledPackageInfo, emptyInstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Simple.Utils (rawSystemExit, copyFileVerbose, die) -import Distribution.Simple.Hugs (hugsPackageDir) -import Distribution.Simple.GHCPackageConfig (mkGHCPackageConfig, showGHCPackageConfig) -import qualified Distribution.Simple.GHCPackageConfig +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.System import Distribution.Compat.Directory - (createDirectoryIfMissing,removeDirectoryRecursive, + (removeDirectoryRecursive, setPermissions, getPermissions, Permissions(executable) ) -import Distribution.Compat.FilePath (joinFileName, joinPaths, splitFileName, - isAbsolutePath) +import System.FilePath ((), (<.>), isAbsolute) -import System.Directory(doesFileExist, removeFile, getCurrentDirectory) +import System.Directory( removeFile, getCurrentDirectory) import System.IO.Error (try) -import Control.Monad (when, unless) -import Data.Maybe (isNothing, fromJust) +import Control.Monad (when) +import Data.Maybe (isNothing, fromJust, fromMaybe) import Data.List (partition) #ifdef DEBUG -import HUnit (Test) +import Test.HUnit (Test) #endif regScriptLocation :: FilePath -#if mingw32_HOST_OS || mingw32_TARGET_OS -regScriptLocation = "register.bat" -#else -regScriptLocation = "register.sh" -#endif +regScriptLocation = case os of + Windows _ -> "register.bat" + _ -> "register.sh" unregScriptLocation :: FilePath -#if mingw32_HOST_OS || mingw32_TARGET_OS -unregScriptLocation = "unregister.bat" -#else -unregScriptLocation = "unregister.sh" -#endif +unregScriptLocation = case os of + Windows _ -> "unregister.bat" + _ -> "unregister.sh" -- ----------------------------------------------------------------------------- -- Registration @@ -121,78 +122,80 @@ -> IO () register pkg_descr lbi regFlags | isNothing (library pkg_descr) = do - setupMessage "No package to register" pkg_descr + setupMessage (regVerbose regFlags) "No package to register" 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 - verbose = regVerbose regFlags - user = regUser regFlags `userOverride` userConf lbi + genPkgConf = regGenPkgConf regFlags + genPkgConfigDefault = showPackageId (package pkg_descr) <.> "conf" + genPkgConfigFile = fromMaybe genPkgConfigDefault + (regPkgConfFile regFlags) + verbosity = regVerbose regFlags + packageDB = fromMaybe (withPackageDB lbi) (regPackageDB regFlags) inplace = regInPlace regFlags - setupMessage (if genScript - then ("Writing registration script: " ++ regScriptLocation) - else "Registering") - pkg_descr + message | genPkgConf = "Writing package registration file: " + ++ genPkgConfigFile ++ " for" + | genScript = "Writing registration script: " + ++ regScriptLocation ++ " for" + | otherwise = "Registering" + setupMessage (regVerbose regFlags) message pkg_descr + case compilerFlavor (compiler lbi) of GHC -> do - config_flags <- - if user - then if ghc_63_plus - then return ["--user"] - else do - GHC.maybeCreateLocalPackageConfig - localConf <- GHC.localPackageConfig - pkgConfWriteable <- GHC.canWriteLocalPackageConfig - when (not pkgConfWriteable && not genScript) - $ userPkgConfErr localConf - return ["--config-file=" ++ localConf] - else return [] + 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] - let instConf = if inplace then inplacePkgConfigFile - else installedPkgConfigFile + let instConf | genPkgConf = genPkgConfigFile + | inplace = inplacePkgConfigFile + | otherwise = installedPkgConfigFile - instConfExists <- doesFileExist instConf - when (not instConfExists && not genScript) $ do - when (verbose > 0) $ - putStrLn ("create " ++ instConf) - writeInstalledConfig pkg_descr lbi inplace + when (genPkgConf || not genScript) $ do + info verbosity ("create " ++ instConf) + writeInstalledConfig pkg_descr lbi inplace (Just instConf) - let register_flags - | ghc_63_plus = "update": -#if !(mingw32_HOST_OS || mingw32_TARGET_OS) - if genScript - then [] - else -#endif - [instConf] - | otherwise = "--update-package": -#if !(mingw32_HOST_OS || mingw32_TARGET_OS) - if genScript - then [] - else -#endif - ["--input-file="++instConf] - - let allFlags = register_flags - ++ config_flags - ++ if ghc_63_plus && genScript then ["-"] else [] - let pkgTool = case regWithHcPkg regFlags of - Just f -> f - Nothing -> compilerPkgTool (compiler lbi) + let register_flags + | ghc_63_plus = 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 - if genScript - then do cfg <- showInstalledConfig pkg_descr lbi inplace - rawSystemPipe regScriptLocation verbose cfg - pkgTool allFlags - else rawSystemExit verbose pkgTool allFlags + let allFlags = config_flags ++ register_flags + let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) + case () of + _ | genPkgConf -> return () + | genScript -> + do cfg <- showInstalledConfig pkg_descr lbi inplace + rawSystemPipe pkgTool regScriptLocation cfg allFlags + _ -> rawSystemProgram verbosity pkgTool allFlags + Hugs -> do when inplace $ die "--inplace is not supported with Hugs" - createDirectoryIfMissing True (hugsPackageDir pkg_descr lbi) - copyFileVerbose verbose installedPkgConfigFile - (hugsPackageDir pkg_descr lbi `joinFileName` "package.conf") - JHC -> when (verbose > 0) $ putStrLn "registering for JHC (nothing to do)" - _ -> die ("only registering with GHC is implemented") + let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + createDirectoryIfMissingVerbose verbosity True (libdir installDirs) + copyFileVerbose verbosity installedPkgConfigFile + (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 = @@ -204,11 +207,14 @@ -- |Register doesn't drop the register info file, it must be done in a -- separate step. -writeInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool -> IO () -writeInstalledConfig pkg_descr lbi inplace = do +writeInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool + -> Maybe FilePath -> IO () +writeInstalledConfig pkg_descr lbi inplace instConfOverride = do pkg_config <- showInstalledConfig pkg_descr lbi inplace - writeFile (if inplace then inplacePkgConfigFile else installedPkgConfigFile) - (pkg_config ++ "\n") + let instConfDefault | inplace = inplacePkgConfigFile + | otherwise = installedPkgConfigFile + 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 @@ -228,15 +234,22 @@ removeInstalledConfig :: IO () removeInstalledConfig = do - try (removeFile installedPkgConfigFile) >> return () - try (removeFile inplacePkgConfigFile) >> return () + try $ removeFile installedPkgConfigFile + try $ removeFile inplacePkgConfigFile + return () -installedPkgConfigFile :: String -installedPkgConfigFile = ".installed-pkg-config" +removeRegScripts :: IO () +removeRegScripts = do + try $ removeFile regScriptLocation + try $ removeFile unregScriptLocation + return () -inplacePkgConfigFile :: String -inplacePkgConfigFile = ".inplace-pkg-config" +installedPkgConfigFile :: FilePath +installedPkgConfigFile = distPref "installed-pkg-config" +inplacePkgConfigFile :: FilePath +inplacePkgConfigFile = distPref "inplace-pkg-config" + -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo @@ -250,12 +263,23 @@ let lib = fromJust (library pkg_descr) -- checked for Nothing earlier bi = libBuildInfo lib - build_dir = pwd `joinFileName` buildDir lbi - libdir = mkLibDir pkg_descr lbi NoCopyDest - incdir = mkIncludeDir libdir - (absinc,relinc) = partition isAbsolutePath (includeDirs bi) - haddockDir = mkHaddockDir pkg_descr lbi NoCopyDest - haddockFile = joinPaths haddockDir (haddockName pkg_descr) + 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)) + } + } NoCopyDest + (absinc,relinc) = partition isAbsolute (includeDirs bi) + installIncludeDir | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + haddockDir | inplace = haddockdir inplaceDirs pkg_descr + | otherwise = haddockdir installDirs pkg_descr + libraryDir | inplace = build_dir + | otherwise = libdir installDirs in return emptyInstalledPackageInfo{ IPI.package = package pkg_descr, @@ -271,24 +295,21 @@ IPI.exposed = True, IPI.exposedModules = exposedModules lib, IPI.hiddenModules = otherModules bi, - IPI.importDirs = [if inplace then build_dir else libdir], - IPI.libraryDirs = (if inplace then build_dir else libdir) - : extraLibDirs bi, + IPI.importDirs = [libraryDir], + IPI.libraryDirs = libraryDir : extraLibDirs bi, IPI.hsLibraries = ["HS" ++ showPackageId (package pkg_descr)], IPI.extraLibraries = extraLibs bi, - IPI.includeDirs = absinc - ++ if inplace - then map (pwd `joinFileName`) relinc - else [incdir], - IPI.includes = includes bi ++ map (snd.splitFileName) - (installIncludes bi), + IPI.includeDirs = absinc ++ if inplace + then map (pwd ) relinc + else installIncludeDir, + IPI.includes = includes bi, IPI.depends = packageDeps lbi, IPI.hugsOptions = concat [opts | (Hugs,opts) <- options bi], IPI.ccOptions = ccOptions bi, IPI.ldOptions = ldOptions bi, IPI.frameworkDirs = [], IPI.frameworks = frameworks bi, - IPI.haddockInterfaces = [haddockFile], + IPI.haddockInterfaces = [haddockDir haddockName pkg_descr], IPI.haddockHTMLs = [haddockDir] } @@ -297,77 +318,86 @@ unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg_descr lbi regFlags = do - setupMessage "Unregistering" pkg_descr + setupMessage (regVerbose regFlags) "Unregistering" pkg_descr let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] [] genScript = regGenScript regFlags - verbose = regVerbose regFlags - user = regUser regFlags `userOverride` userConf lbi + verbosity = regVerbose regFlags + packageDB = fromMaybe (withPackageDB lbi) (regPackageDB regFlags) + installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest case compilerFlavor (compiler lbi) of GHC -> do - config_flags <- - if user - then if ghc_63_plus - then return ["--user"] - else do - instConfExists <- doesFileExist installedPkgConfigFile - localConf <- GHC.localPackageConfig - unless instConfExists (userPkgConfErr localConf) - return ["--config-file=" ++ localConf] - else return [] + 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] + let removeCmd = if ghc_63_plus then ["unregister",showPackageId (package pkg_descr)] else ["--remove-package="++(pkgName $ package pkg_descr)] - let pkgTool = case regWithHcPkg regFlags of - Just f -> f - Nothing -> compilerPkgTool (compiler lbi) - rawSystemEmit unregScriptLocation genScript verbose pkgTool - (removeCmd++config_flags) + let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi) + allArgs = removeCmd ++ config_flags + if genScript + then rawSystemEmit pkgTool unregScriptLocation allArgs + else rawSystemProgram verbosity pkgTool allArgs Hugs -> do - try $ removeDirectoryRecursive (hugsPackageDir pkg_descr lbi) + try $ removeDirectoryRecursive (libdir installDirs) return () + NHC -> do + try $ removeDirectoryRecursive (libdir installDirs) + return () _ -> die ("only unregistering with GHC and Hugs is implemented") --- |Like rawSystemExit, but optionally emits to a script instead of --- exiting. FIX: chmod +x? -rawSystemEmit :: FilePath -- ^Script name - -> Bool -- ^if true, emit, if false, run - -> Int -- ^Verbosity - -> FilePath -- ^Program to run - -> [String] -- ^Args +-- |Like rawSystemProgram, but emits to a script instead of exiting. +-- FIX: chmod +x? +rawSystemEmit :: ConfiguredProgram -- ^Program to run + -> FilePath -- ^Script name + -> [String] -- ^Args -> IO () -rawSystemEmit _ False verbosity path args - = rawSystemExit verbosity path args -rawSystemEmit scriptName True verbosity path args = do -#if mingw32_HOST_OS || mingw32_TARGET_OS - writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) -#else - writeFile scriptName ("#!/bin/sh\n\n" - ++ (path ++ concatMap (' ':) args) - ++ "\n") - p <- getPermissions scriptName - setPermissions scriptName p{executable=True} -#endif +rawSystemEmit prog scriptName extraArgs + = case os of + Windows _ -> + writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) + _ -> do writeFile scriptName ("#!/bin/sh\n\n" + ++ (path ++ concatMap (' ':) args) + ++ "\n") + p <- getPermissions scriptName + setPermissions scriptName p{executable=True} + where args = programArgs prog ++ extraArgs + path = programPath prog -- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x -rawSystemPipe :: FilePath -- ^Script location - -> Int -- ^Verbosity - -> String -- ^where to pipe from - -> FilePath -- ^Program to run - -> [String] -- ^Args +rawSystemPipe :: ConfiguredProgram + -> FilePath -- ^Script location + -> String -- ^where to pipe from + -> [String] -- ^Args -> IO () -rawSystemPipe scriptName verbose pipeFrom path args = do -#if mingw32_HOST_OS || mingw32_TARGET_OS - writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) -#else - writeFile scriptName ("#!/bin/sh\n\n" - ++ "echo '" ++ pipeFrom - ++ "' | " - ++ (path ++ concatMap (' ':) args) - ++ "\n") - p <- getPermissions scriptName - setPermissions scriptName p{executable=True} -#endif +rawSystemPipe prog scriptName pipeFrom extraArgs + = case os of + Windows _ -> + writeFile scriptName ("@" ++ path ++ concatMap (' ':) args) + _ -> do writeFile scriptName ("#!/bin/sh\n\n" + ++ "echo '" ++ escapeForShell pipeFrom + ++ "' | " + ++ (path ++ concatMap (' ':) args) + ++ "\n") + p <- getPermissions scriptName + setPermissions scriptName p{executable=True} + where escapeForShell [] = [] + escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs + escapeForShell (c :cs) = c : escapeForShell cs + args = programArgs prog ++ extraArgs + path = programPath prog -- ------------------------------------------------------------ -- * Testing diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Setup.hs @@ -0,0 +1,1024 @@ +{-# 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 + + 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, + 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 + | 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 "" ["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-arg(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 (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? +-} + diff --git a/Distribution/Simple/SetupWrapper.hs b/Distribution/Simple/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/SetupWrapper.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006 +-- +-- Maintainer : http://hackage.haskell.org/trac/hackage +-- Stability : alpha +-- Portability : portable +-- +-- The user interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Simple.SetupWrapper (setupWrapper) where + +import qualified Distribution.Make as Make +import Distribution.Simple +import Distribution.Simple.Utils +import Distribution.Simple.Configure + ( configCompiler, getInstalledPackages, + configDependency ) +import Distribution.Simple.Setup ( reqPathArg ) +import Distribution.PackageDescription + ( readPackageDescription, + packageDescription, + PackageDescription(..), + BuildType(..), cabalVersion ) +import Distribution.Simple.LocalBuildInfo ( distPref ) +import Distribution.Simple.Program ( ProgramConfiguration, + emptyProgramConfiguration, + rawSystemProgramConf, ghcProgram ) +import Distribution.Simple.GHC (ghcVerbosityOptions) +import Distribution.GetOpt +import System.Directory +import Distribution.Compat.Exception ( finally ) +import Distribution.Verbosity +import System.FilePath ((), (<.>)) +import Control.Monad ( when, unless ) +import Data.Maybe ( fromMaybe ) + + -- read the .cabal file + -- - attempt to find the version of Cabal required + + -- if the Cabal file specifies the build type (not Custom), + -- - behave like a boilerplate Setup.hs of that type + -- otherwise, + -- - if we find GHC, + -- - build the Setup script with the right version of Cabal + -- - invoke it with args + -- - if we find runhaskell (TODO) + -- - use runhaskell to invoke it + -- + -- Later: + -- - add support for multiple packages, by figuring out + -- dependencies here and building/installing the sub packages + -- in the right order. +setupWrapper :: + [String] -- ^ Command-line arguments. + -> Maybe FilePath -- ^ Directory to run in. If 'Nothing', the current directory is used. + -> IO () +setupWrapper args mdir = inDir mdir $ do + let (flag_fn, _, _, errs) = getOpt' Permute opts args + when (not (null errs)) $ die (unlines errs) + let Flags { withCompiler = hc, withHcPkg = hcPkg, withVerbosity = verbosity + } = foldr (.) id flag_fn defaultFlags + + pkg_descr_file <- defaultPackageDesc verbosity + ppkg_descr <- readPackageDescription verbosity pkg_descr_file + + let + setupDir = distPref "setup" + setupHs = setupDir "setup" <.> "hs" + setupProg = setupDir "setup" <.> exeExtension + trySetupScript f on_fail = do + b <- doesFileExist f + if not b then on_fail else do + hasSetup <- do b' <- doesFileExist setupProg + if not b' then return False else do + t1 <- getModificationTime f + t2 <- getModificationTime setupProg + return (t1 < t2) + unless hasSetup $ do + (comp, conf) <- configCompiler (Just GHC) hc hcPkg + emptyProgramConfiguration normal + let verRange = descCabalVersion (packageDescription ppkg_descr) + cabal_flag <- configCabalFlag verbosity verRange comp conf + createDirectoryIfMissingVerbose verbosity True setupDir + rawSystemProgramConf verbosity ghcProgram conf $ + cabal_flag + ++ ["--make", f, "-o", setupProg + ,"-odir", setupDir, "-hidir", setupDir] + ++ ghcVerbosityOptions verbosity + rawSystemExit verbosity setupProg args + + case lookup (buildType (packageDescription ppkg_descr)) 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 + trySetupScript setupHs $ error "panic! shouldn't happen" + Nothing -> + trySetupScript "Setup.hs" $ + trySetupScript "Setup.lhs" $ + die "no special Build-Type, but lacks Setup.hs or Setup.lhs" + +buildTypes :: [(BuildType, ([String] -> IO (), String))] +buildTypes = [ + (Simple, (defaultMainArgs, "import Distribution.Simple; main=defaultMain")), + (Configure, (defaultMainWithHooksArgs defaultUserHooks, + "import Distribution.Simple; main=defaultMainWithHooks defaultUserHooks")), + (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, + withHcPkg :: Maybe FilePath, + withVerbosity :: Verbosity + } + +defaultFlags :: Flags +defaultFlags = Flags { + withCompiler = Nothing, + withHcPkg = Nothing, + withVerbosity = normal + } + +setWithCompiler :: Maybe FilePath -> Flags -> Flags +setWithCompiler f flags = flags{ withCompiler=f } + +setWithHcPkg :: Maybe FilePath -> Flags -> Flags +setWithHcPkg f flags = flags{ withHcPkg=f } + +setVerbosity :: Verbosity -> Flags -> Flags +setVerbosity v flags = flags{ withVerbosity=v } + +opts :: [OptDescr (Flags -> Flags)] +opts = [ + Option "w" ["with-setup-compiler"] (reqPathArg (setWithCompiler.Just)) + "give the path to a particular compiler to use on setup", + Option "" ["with-setup-hc-pkg"] (reqPathArg (setWithHcPkg.Just)) + "give the path to the package tool to use on setup", + Option "v" ["verbose"] (OptArg (setVerbosity . 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 [] + -- user packages are *allowed* here, no portability problem + cabal_pkgid <- configDependency verbosity ipkgs (Dependency "Cabal" range) + return ["-package", showPackageId cabal_pkgid] diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -8,6 +8,9 @@ -- Stability : alpha -- Portability : portable -- +-- Implements the \"@.\/setup sdist@\" command, which creates a source +-- distribution for this package. That is, packs up the source code +-- into a tarball. {- Copyright (c) 2003-2004, Simon Marlow All rights reserved. @@ -44,7 +47,11 @@ -- we can't easily look inside a tarball once its created. module Distribution.Simple.SrcDist ( - sdist + sdist + ,createArchive + ,prepareTree + ,tarBallName + ,copyFileTo #ifdef DEBUG ,hunitTests #endif @@ -52,94 +59,134 @@ import Distribution.PackageDescription (PackageDescription(..), BuildInfo(..), Executable(..), Library(..), - setupMessage, libModules) + withLib, withExe, setupMessage) import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion)) -import Distribution.Version (Version(versionBranch)) -import Distribution.Simple.Utils - (smartCopySources, die, findPackageDesc, findFile, copyFileVerbose) -import Distribution.Setup (SDistFlags(..)) -import Distribution.PreProcess (PPSuffixHandler, ppSuffixes, removePreprocessed) +import Distribution.Version (Version(versionBranch), VersionRange(AnyVersion)) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, + smartCopySources, die, warn, notice, + findPackageDesc, findFile, copyFileVerbose) +import Distribution.Simple.Setup (SDistFlags(..)) +import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, + rawSystemProgram, tarProgram ) +#ifndef __NHC__ +import Control.Exception (finally) +#endif import Control.Monad(when) import Data.Char (isSpace, toLower) import Data.List (isPrefixOf) -import System.Cmd (system) import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) import Distribution.Compat.Directory (doesFileExist, doesDirectoryExist, - getCurrentDirectory, createDirectoryIfMissing, removeDirectoryRecursive) -import Distribution.Compat.FilePath (joinFileName, splitFileName) + getCurrentDirectory, removeDirectoryRecursive) +import Distribution.Verbosity +import System.FilePath ((), takeDirectory, isAbsolute) #ifdef DEBUG -import HUnit (Test) +import Test.HUnit (Test) #endif --- |Create a source distribution. FIX: Calls tar directly (won't work --- on windows). -sdist :: PackageDescription - -> SDistFlags -- verbose & snapshot +#ifdef __NHC__ +finally :: IO a -> IO b -> IO a +x `finally` y = do { a <- x; y; return a } +#endif + +-- |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 -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO () -sdist pkg_descr_orig (SDistFlags snapshot verbose) 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 - setupMessage "Building source dist for" pkg_descr +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 () + 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) } + +-- |Prepare a directory tree of source files. +prepareTree :: PackageDescription -- ^info from the cabal file + -> Verbosity -- ^verbosity + -> Maybe LocalBuildInfo + -> Bool -- ^snapshot + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> Int -- ^date + -> IO FilePath + +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 `joinFileName` (nameVersion pkg_descr) - createDirectoryIfMissing True targetDir + let targetDir = tmpDir (nameVersion pkg_descr) + createDirectoryIfMissingVerbose verbosity True targetDir -- maybe move the library files into place - maybe (return ()) (\l -> prepareDir verbose targetDir pps (libModules pkg_descr) (libBuildInfo l)) - (library pkg_descr) + withLib pkg_descr () $ \ l -> + prepareDir verbosity targetDir pps (exposedModules l) (libBuildInfo l) -- move the executables into place - flip mapM_ (executables pkg_descr) $ \ (Executable _ mainPath exeBi) -> do - prepareDir verbose targetDir pps [] exeBi + withExe pkg_descr $ \ (Executable _ mainPath exeBi) -> do + prepareDir verbosity targetDir pps [] exeBi srcMainFile <- findFile (hsSourceDirs exeBi) mainPath - copyFileTo verbose targetDir srcMainFile + copyFileTo verbosity targetDir srcMainFile flip mapM_ (dataFiles pkg_descr) $ \ file -> do - let (dir, _) = splitFileName file - createDirectoryIfMissing True (targetDir `joinFileName` dir) - copyFileVerbose verbose file (targetDir `joinFileName` file) + let dir = takeDirectory file + createDirectoryIfMissingVerbose verbosity True (targetDir dir) + copyFileVerbose verbosity file (targetDir file) + when (not (null (licenseFile pkg_descr))) $ - copyFileTo verbose targetDir (licenseFile pkg_descr) + copyFileTo verbosity targetDir (licenseFile pkg_descr) flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do - copyFileTo verbose targetDir fpath + copyFileTo verbosity targetDir fpath + + -- copy the install-include files + withLib pkg_descr () $ \ 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." + -- setup isn't listed in the description file. hsExists <- doesFileExist "Setup.hs" lhsExists <- doesFileExist "Setup.lhs" - if hsExists then copyFileTo verbose targetDir "Setup.hs" - else if lhsExists then copyFileTo verbose targetDir "Setup.lhs" - else writeFile (targetDir `joinFileName` "Setup.hs") $ unlines [ + if hsExists then copyFileTo verbosity targetDir "Setup.hs" + else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" + else writeFile (targetDir "Setup.hs") $ unlines [ "import Distribution.Simple", "main = defaultMainWithHooks defaultUserHooks"] -- the description file itself - descFile <- getCurrentDirectory >>= findPackageDesc - let targetDescFile = targetDir `joinFileName` descFile + 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 verbose descFile targetDescFile - - let tarBallFilePath = targetPref `joinFileName` tarBallName pkg_descr - system $ "(cd " ++ tmpDir - ++ ";tar cf - " ++ (nameVersion pkg_descr) ++ ") | gzip -9 >" - ++ tarBallFilePath - removeDirectoryRecursive tmpDir - putStrLn $ "Source tarball created: " ++ tarBallFilePath + else copyFileVerbose verbosity descFile targetDescFile + return targetDir 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) } appendVersion :: Int -> String -> String appendVersion n line @@ -150,24 +197,53 @@ 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 + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: PackageDescription -- ^info from cabal file + -> Verbosity -- ^verbosity + -> 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 + + (tarProg, _) <- requireProgram verbosity tarProgram AnyVersion + (maybe defaultProgramConfiguration withPrograms mb_lbi) + + -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?) + -- [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 + return tarBallFilePath + -- |Move the sources into place based on buildInfo -prepareDir :: Int -- ^verbose +prepareDir :: Verbosity -- ^verbosity -> FilePath -- ^TargetPrefix -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> [String] -- ^Exposed modules -> BuildInfo -> IO () -prepareDir verbose inPref pps mods BuildInfo{hsSourceDirs=srcDirs, otherModules=mods', cSources=cfiles} +prepareDir verbosity inPref pps mods BuildInfo{hsSourceDirs=srcDirs, otherModules=mods', cSources=cfiles} = do let suff = ppSuffixes pps ++ ["hs", "lhs"] - smartCopySources verbose srcDirs inPref (mods++mods') suff True True - removePreprocessed (map (joinFileName inPref) srcDirs) mods suff - mapM_ (copyFileTo verbose inPref) cfiles + smartCopySources verbosity srcDirs inPref (mods++mods') suff True True + mapM_ (copyFileTo verbosity inPref) cfiles -copyFileTo :: Int -> FilePath -> FilePath -> IO () -copyFileTo verbose dir file = do - let targetFile = dir `joinFileName` file - createDirectoryIfMissing True (fst (splitFileName targetFile)) - copyFileVerbose verbose file targetFile +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + copyFileVerbose verbosity file targetFile ------------------------------------------------------------ diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -42,34 +42,37 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Utils ( - die, - dieWithLocation, - warn, - rawSystemPath, - rawSystemVerbose, - rawSystemExit, + die, + dieWithLocation, + warn, notice, info, debug, + breaks, + wrapText, + rawSystemExit, + rawSystemStdout, + rawSystemStdout', maybeExit, xargs, matchesDescFile, rawSystemPathExit, smartCopySources, + createDirectoryIfMissingVerbose, copyFileVerbose, copyDirectoryRecursiveVerbose, moduleToFilePath, + moduleToFilePath2, mkLibName, mkProfLibName, + mkSharedLibName, currentDir, - dirOf, dotToSep, - withTempFile, findFile, defaultPackageDesc, findPackageDesc, defaultHookedPackageDesc, findHookedPackageDesc, - distPref, - haddockPref, - srcPref, + exeExtension, + objExtension, + dllExtension, #ifdef DEBUG hunitTests #endif @@ -83,32 +86,56 @@ #endif #endif -import Distribution.Compat.RawSystem (rawSystem) -import Distribution.Compat.Exception (finally) +import Control.Monad + ( when, filterM, unless, liftM2 ) +import Data.List + ( nub, unfoldr ) -import Control.Monad(when, filterM, unless) -import Data.List (nub, unfoldr) -import System.Environment (getProgName) -import System.IO (hPutStrLn, stderr, hFlush, stdout) -import System.IO.Error +import System.Directory + ( getDirectoryContents, getCurrentDirectory, doesDirectoryExist + , doesFileExist, removeFile ) +import System.Environment + ( getProgName ) import System.Exit -#if (__GLASGOW_HASKELL__ || __HUGS__) && !(mingw32_HOST_OS || mingw32_TARGET_OS) -import System.Posix.Internals (c_getpid) -#endif - -import Distribution.Compat.FilePath - (splitFileName, splitFileExt, joinFileName, joinFileExt, joinPaths, - pathSeparator,splitFilePath) -import System.Directory (getDirectoryContents, getCurrentDirectory - , doesDirectoryExist, doesFileExist, removeFile, getPermissions - , Permissions(executable)) + ( exitWith, ExitCode(..) ) +import System.FilePath + ( takeDirectory, takeExtension, (), (<.>), pathSeparator ) +import System.IO + ( hPutStrLn, stderr, hFlush, stdout, openFile, IOMode(WriteMode) ) +import System.IO.Error + ( try ) import Distribution.Compat.Directory - (copyFile, findExecutable, createDirectoryIfMissing, - getDirectoryContentsWithoutSpecial) + ( copyFile, findExecutable, createDirectoryIfMissing + , getDirectoryContentsWithoutSpecial) +import Distribution.Compat.RawSystem + ( rawSystem ) +import Distribution.Compat.Exception + ( bracket ) +import Distribution.System + ( OS(..), os ) +import Distribution.Version + (showVersion) +import Distribution.Package + (PackageIdentifier(..)) +#if __GLASGOW_HASKELL__ >= 604 +import Control.Exception (evaluate) +import System.Process (runProcess, waitForProcess) +#else +import System.Cmd (system) +#endif +import System.IO (hClose) + +#if __GLASGOW_HASKELL__ >= 604 +import Distribution.Compat.TempFile (openTempFile) +#else +import Distribution.Compat.TempFile (withTempFile) +#endif +import Distribution.Verbosity + #ifdef DEBUG -import HUnit ((~:), (~=?), Test(..), assertEqual) +import Test.HUnit ((~:), (~=?), Test(..), assertEqual) #endif -- ------------------------------------------------------------------------------- Utils for setup @@ -124,78 +151,159 @@ hPutStrLn stderr (pname ++ ": " ++ msg) exitWith (ExitFailure 1) -warn :: String -> IO () -warn msg = do - hFlush stdout - pname <- getProgName - hPutStrLn stderr (pname ++ ": Warning: " ++ msg) +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = + when (verbosity >= normal) $ do + hFlush stdout + hPutStrLn stderr ("Warning: " ++ msg) +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = + when (verbosity >= normal) $ + putStrLn msg + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = + when (verbosity >= verbose) $ + putStrLn msg + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = + when (verbosity >= deafening) $ + putStrLn msg + -- ----------------------------------------------------------------------------- --- rawSystem variants -rawSystemPath :: Int -> String -> [String] -> IO ExitCode -rawSystemPath verbose prog args = do - r <- findExecutable prog - case r of - Nothing -> die ("Cannot find: " ++ prog) - Just path -> rawSystemVerbose verbose path args +-- Helper functions -rawSystemVerbose :: Int -> FilePath -> [String] -> IO ExitCode -rawSystemVerbose verbose prog args = do - when (verbose > 0) $ - putStrLn (prog ++ concatMap (' ':) args) - e <- doesFileExist prog - if e - then do perms <- getPermissions prog - if (executable perms) - then rawSystem prog args - else die ("Error: file is not executable: " ++ show prog) - else die ("Error: file does not exist: " ++ show prog) +breaks :: (a -> Bool) -> [a] -> [[a]] +breaks _ [] = [] +breaks f xs = case span f xs of + (_, xs') -> + case break f xs' of + (v, xs'') -> + v : breaks f xs'' +-- Wraps a list of words text to a list of lines of a particular width. +wrapText :: Int -> [String] -> [String] +wrapText width = map unwords . wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- ----------------------------------------------------------------------------- +-- rawSystem variants maybeExit :: IO ExitCode -> IO () maybeExit cmd = do res <- cmd - if res /= ExitSuccess - then exitWith res - else return () + unless (res == ExitSuccess) $ exitWith res +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args + | verbosity >= deafening = print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + -- Exit with the same exitcode if the subcommand fails -rawSystemExit :: Int -> FilePath -> [String] -> IO () -rawSystemExit verbose path args = do - when (verbose > 0) $ - putStrLn (path ++ concatMap (' ':) args) +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = do + printRawCommandAndArgs verbosity path args maybeExit $ rawSystem path args -- Exit with the same exitcode if the subcommand fails -rawSystemPathExit :: Int -> String -> [String] -> IO () -rawSystemPathExit verbose prog args = do - maybeExit $ rawSystemPath verbose prog args +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 +-- Run a command and return its output +rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout verbosity path args = do + (output, exitCode) <- rawSystemStdout' verbosity path args + unless (exitCode == ExitSuccess) $ exitWith exitCode + return output + +rawSystemStdout' :: Verbosity -> FilePath -> [String] -> IO (String, ExitCode) +rawSystemStdout' verbosity path args = do + printRawCommandAndArgs verbosity path args + +#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 "." "tmp") (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) +#else + withTempFile "." "" $ \tmpName -> do + let quote name = "'" ++ name ++ "'" + exitCode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName + output <- readFile tmpName + length output `seq` return (output, exitCode) +#endif + -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. -- -- Use it with either of the rawSystem variants above. For example: -- --- > xargs (32*1024) (rawSystemPath verbose) prog fixedArgs bigArgs +-- > xargs (32*1024) (rawSystemPathExit verbosity) prog fixedArgs bigArgs -- -xargs :: Int -> (FilePath -> [String] -> IO ExitCode) - -> FilePath -> [String] -> [String] -> IO ExitCode -xargs maxSize rawSystem prog fixedArgs bigArgs = +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = let fixedArgSize = sum (map length fixedArgs) + length fixedArgs chunkSize = maxSize - fixedArgSize - loop [] = return ExitSuccess - loop (args:remainingArgs) = do - status <- rawSystem prog (fixedArgs ++ args) - case status of - ExitSuccess -> loop remainingArgs - _ -> return status - in loop (chunks chunkSize bigArgs) + in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) where chunks len = unfoldr $ \s -> if null s then Nothing else Just (chunk [] len s) - chunk acc len [] = (reverse acc,[]) + chunk acc _ [] = (reverse acc,[]) chunk acc len (s:ss) | len' < len = chunk (s:acc) (len-len'-1) ss | otherwise = (reverse acc, s:ss) @@ -232,10 +340,10 @@ -> IO [(FilePath, FilePath)] -- ^locations and relative names moduleToFilePath2 locs mname possibleSuffixes = filterM exists $ - [(loc, fname `joinFileExt` ext) | loc <- locs, ext <- possibleSuffixes] + [(loc, fname <.> ext) | loc <- locs, ext <- possibleSuffixes] where fname = dotToSep mname - exists (loc, relname) = doesFileExist (loc `joinFileName` relname) + exists (loc, relname) = doesFileExist (loc relname) -- |Get the possible file paths based on this module name. moduleToPossiblePaths :: FilePath -- ^search prefix @@ -243,19 +351,19 @@ -> [String] -- ^possible suffixes -> [FilePath] moduleToPossiblePaths searchPref s possibleSuffixes = - let fname = searchPref `joinFileName` (dotToSep s) - in [fname `joinFileExt` ext | ext <- possibleSuffixes] + let fname = searchPref (dotToSep s) + in [fname <.> ext | ext <- possibleSuffixes] findFile :: [FilePath] -- ^search locations -> FilePath -- ^File Name -> IO FilePath findFile prefPathsIn locPath = do let prefPaths = nub prefPathsIn -- ignore dups - paths <- filterM doesFileExist [prefPath `joinFileName` locPath | prefPath <- prefPaths] + paths <- filterM doesFileExist [prefPath locPath | prefPath <- prefPaths] case nub paths of -- also ignore dups, though above nub should fix this. [path] -> return path [] -> die (locPath ++ " doesn't exist") - paths -> die (locPath ++ " is found in multiple places:" ++ unlines (map ((++) " ") paths)) + paths' -> die (locPath ++ " is found in multiple places:" ++ unlines (map ((++) " ") paths')) dotToSep :: String -> String dotToSep = map dts @@ -268,7 +376,7 @@ -- the input search suffixes. It copies the files into the target -- directory. -smartCopySources :: Int -- ^verbose +smartCopySources :: Verbosity -- ^verbosity -> [FilePath] -- ^build prefix (location of objects) -> FilePath -- ^Target directory -> [String] -- ^Modules @@ -276,19 +384,19 @@ -> Bool -- ^Exit if no such modules -> Bool -- ^Preserve directory structure -> IO () -smartCopySources verbose srcDirs targetDir sources searchSuffixes exitIfNone preserveDirs - = do createDirectoryIfMissing True targetDir +smartCopySources verbosity srcDirs targetDir sources searchSuffixes exitIfNone preserveDirs + = do createDirectoryIfMissingVerbose verbosity True targetDir allLocations <- mapM moduleToFPErr sources - let copies = [(srcDir `joinFileName` name, + let copies = [(srcDir name, if preserveDirs - then targetDir `joinFileName` srcDir `joinFileName` name - else targetDir `joinFileName` name) | + then targetDir srcDir name + else targetDir name) | (srcDir, name) <- concat allLocations] -- Create parent directories for everything: - mapM_ (createDirectoryIfMissing True) $ nub $ - [fst (splitFileName targetFile) | (_, targetFile) <- copies] + mapM_ (createDirectoryIfMissingVerbose verbosity True) $ nub $ + [takeDirectory targetFile | (_, targetFile) <- copies] -- Put sources into place: - sequence_ [copyFileVerbose verbose srcFile destFile | + sequence_ [copyFileVerbose verbosity srcFile destFile | (srcFile, destFile) <- copies] where moduleToFPErr m = do p <- moduleToFilePath2 srcDirs m searchSuffixes @@ -297,29 +405,33 @@ ++ " with any suffix: " ++ (show searchSuffixes))) return p -copyFileVerbose :: Int -> FilePath -> FilePath -> IO () -copyFileVerbose verbose src dest = do - when (verbose > 0) $ - putStrLn ("copy " ++ src ++ " to " ++ dest) +createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO () +createDirectoryIfMissingVerbose verbosity parentsToo dir = do + let msgParents = if parentsToo then " (and its parents)" else "" + info verbosity ("Creating " ++ dir ++ msgParents) + createDirectoryIfMissing parentsToo dir + +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = do + info verbosity ("copy " ++ src ++ " to " ++ dest) copyFile src dest -- adaptation of removeDirectoryRecursive -copyDirectoryRecursiveVerbose :: Int -> FilePath -> FilePath -> IO () -copyDirectoryRecursiveVerbose verbose srcDir destDir = do - when (verbose > 0) $ - putStrLn ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") +copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursiveVerbose verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") let aux src dest = let cp :: FilePath -> IO () - cp f = let srcFile = joinPaths src f - destFile = joinPaths dest f - in do success <- try (copyFileVerbose verbose srcFile destFile) + cp f = let srcFile = src f + destFile = dest f + in do success <- try (copyFileVerbose verbosity srcFile destFile) case success of Left e -> do isDir <- doesDirectoryExist srcFile -- If f is not a directory, re-throw the error unless isDir $ ioError e aux srcFile destFile Right _ -> return () - in do createDirectoryIfMissing False dest + in do createDirectoryIfMissingVerbose verbosity False dest getDirectoryContentsWithoutSpecial src >>= mapM_ cp in aux srcDir destDir @@ -332,59 +444,26 @@ currentDir :: FilePath currentDir = "." -dirOf :: FilePath -> FilePath -dirOf f = (\ (x, _, _) -> x) $ (splitFilePath f) - mkLibName :: FilePath -- ^file Prefix -> String -- ^library name. -> String -mkLibName pref lib = pref `joinFileName` ("libHS" ++ lib ++ ".a") +mkLibName pref lib = pref ("libHS" ++ lib ++ ".a") mkProfLibName :: FilePath -- ^file Prefix -> String -- ^library name. -> String mkProfLibName pref lib = mkLibName pref (lib++"_p") --- ------------------------------------------------------------ --- * Some Paths --- ------------------------------------------------------------ -distPref :: FilePath -distPref = "dist" - -srcPref :: FilePath -srcPref = distPref `joinFileName` "src" - -haddockPref :: FilePath -haddockPref = foldl1 joinPaths [distPref, "doc", "html"] - --- ------------------------------------------------------------ --- * temporary file names --- ------------------------------------------------------------ - --- 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 - = do x <- getProcessID - findTempName x - where - findTempName x - = do let filename = ("tmp" ++ show x) `joinFileExt` extn - path = tmp_dir `joinFileName` filename - b <- doesFileExist path - if b then findTempName (x+1) - else action path `finally` try (removeFile path) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -foreign import ccall unsafe "_getpid" getProcessID :: IO Int - -- relies on Int == Int32 on Windows -#elif __GLASGOW_HASKELL__ || __HUGS__ -getProcessID :: IO Int -getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral -#else --- error ToDo: getProcessID -foreign import ccall unsafe "getpid" getProcessID :: IO Int -#endif +-- 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 @@ -399,8 +478,10 @@ buildInfoExt :: String buildInfoExt = "buildinfo" +-- > matchesDescFile "blah.Cabal" +-- > not $ matchesDescFile "blag.bleg" matchesDescFile :: FilePath -> Bool -matchesDescFile p = (snd $ splitFileExt p) == cabalExt +matchesDescFile p = (takeExtension p) == '.':cabalExt || p == oldDescFile noDesc :: IO a @@ -411,38 +492,41 @@ ++ show (filter (/= oldDescFile) l) -- |A list of possibly correct description files. Should be pre-filtered. -descriptionCheck :: [FilePath] -> IO FilePath -descriptionCheck [] = noDesc -descriptionCheck [x] +descriptionCheck :: Verbosity -> [FilePath] -> IO FilePath +descriptionCheck _ [] = noDesc +descriptionCheck verbosity [x] | x == oldDescFile - = do warn $ "The filename \"Setup.description\" is deprecated, please move to ." ++ cabalExt + = do warn verbosity $ "The filename \"Setup.description\" is deprecated, please move to ." ++ cabalExt return x | matchesDescFile x = return x | otherwise = noDesc -descriptionCheck [x,y] +descriptionCheck verbosity [x,y] | x == oldDescFile - = do warn $ "The filename \"Setup.description\" is deprecated. Please move out of the way. Using \"" + = do warn verbosity $ "The filename \"Setup.description\" is deprecated. Please move out of the way. Using \"" ++ y ++ "\"" return y | y == oldDescFile - = do warn $ "The filename \"Setup.description\" is deprecated. Please move out of the way. Using \"" + = 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 +descriptionCheck _ l = multiDesc l -- |Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: IO FilePath -defaultPackageDesc = getCurrentDirectory >>= findPackageDesc +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc verbosity + = getCurrentDirectory >>= findPackageDesc verbosity -- |Find a package description file in the given directory. Looks for -- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look +findPackageDesc :: Verbosity -- ^Verbosity + -> FilePath -- ^Where to look -> IO FilePath -- .cabal -findPackageDesc p = do ls <- getDirectoryContents p - let descs = filter matchesDescFile ls - descriptionCheck descs +findPackageDesc verbosity p + = do ls <- getDirectoryContents p + let descs = filter matchesDescFile ls + descriptionCheck verbosity descs -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath) @@ -455,13 +539,44 @@ -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc dir = do ns <- getDirectoryContents dir - case [dir `joinFileName` n | - n <- ns, snd (splitFileExt n) == buildInfoExt] of + case [dir n | + n <- ns, takeExtension n == '.':buildInfoExt] of [] -> return Nothing [f] -> return (Just f) _ -> die ("Multiple files with extension " ++ buildInfoExt) -- ------------------------------------------------------------ +-- * 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 os 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 os of + Windows _ -> "dll" + OSX -> "dylib" + _ -> "so" + +devNull :: FilePath +devNull = case os of + Windows _ -> "NUL" + _ -> "/dev/null" + +-- ------------------------------------------------------------ -- * Testing -- ------------------------------------------------------------ @@ -470,36 +585,19 @@ hunitTests = let suffixes = ["hs", "lhs"] in [TestCase $ -#if mingw32_HOST_OS || mingw32_TARGET_OS 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 + ["Distribution" "Simple" "Build.hs"] mp1 assertEqual "not existing not nothing failed" [] mp2, "moduleToPossiblePaths 1" ~: "failed" ~: - ["Foo\\Bar\\Bang.hs","Foo\\Bar\\Bang.lhs"] + ["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)) -#else - 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, - - "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)) -#endif ] -- |Might want to make this more generic some day, with regexps @@ -513,5 +611,5 @@ = do allFiles <- getDirectoryContents dir return $ filter hasExt allFiles where - hasExt f = snd (splitFileExt f) == extension + hasExt f = takeExtension f == '.':extension #endif diff --git a/Distribution/System.hs b/Distribution/System.hs new file mode 100644 --- /dev/null +++ b/Distribution/System.hs @@ -0,0 +1,14 @@ +module Distribution.System where + +import qualified System.Info + +data OS = Linux | Windows Windows | OSX | Solaris | Other String +data Windows = MingW + +os :: OS +os = case System.Info.os of + "linux" -> Linux + "mingw32" -> Windows MingW + "darwin" -> OSX + "solaris2" -> Solaris + other -> Other other diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs new file mode 100644 --- /dev/null +++ b/Distribution/Verbosity.hs @@ -0,0 +1,110 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Verbosity for Cabal functions + +{- Copyright (c) 2007, Ian Lynagh +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.Verbosity ( + -- * Verbosity + Verbosity, + silent, normal, verbose, deafening, + moreVerbose, lessVerbose, + intToVerbosity, flagToVerbosity, + showForCabal, showForGHC + ) where + +import Data.List (elemIndex) + +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Show, Eq, Ord) + +-- We shouldn't print /anything/ unless an error occurs in silent mode +silent :: Verbosity +silent = Silent + +-- Print stuff we want to see by default +normal :: Verbosity +normal = Normal + +-- Be more verbose about what's going on +verbose :: Verbosity +verbose = Verbose + +-- Not only are we verbose ourselves (perhaps even noisier than when +-- being "verbose"), but we tell everything we run to be verbose too +deafening :: Verbosity +deafening = Deafening + +moreVerbose :: Verbosity -> Verbosity +moreVerbose Silent = Silent --silent should stay silent +moreVerbose Normal = Verbose +moreVerbose Verbose = Deafening +moreVerbose Deafening = Deafening + +lessVerbose :: Verbosity -> Verbosity +lessVerbose Deafening = Verbose +lessVerbose Verbose = Normal +lessVerbose Normal = Silent +lessVerbose Silent = Silent + +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just Silent +intToVerbosity 1 = Just Normal +intToVerbosity 2 = Just Verbose +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 + [(i, "")] -> + case intToVerbosity i of + Just v -> v + Nothing -> error ("Bad verbosity " ++ show i) + _ -> error ("Can't parse verbosity " ++ s) + +showForCabal, showForGHC :: Verbosity -> String + +showForCabal v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] +showForGHC v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,__,verbose,deafening] + where __ = silent -- this will be always ignored by elemIndex diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -45,6 +45,7 @@ -- * Package versions Version(..), showVersion, + readVersion, parseVersion, -- * Version ranges @@ -54,6 +55,7 @@ withinRange, showVersionRange, parseVersionRange, + isAnyVersion, -- * Dependencies Dependency(..), @@ -68,11 +70,13 @@ #endif import Control.Monad ( liftM ) +import Data.Char ( isSpace ) +import Data.Maybe ( listToMaybe ) import Distribution.Compat.ReadP #ifdef DEBUG -import HUnit +import Test.HUnit #endif -- ----------------------------------------------------------------------------- @@ -192,6 +196,10 @@ #endif +readVersion :: String -> Maybe Version +readVersion str = + listToMaybe [ r | (r,s) <- readP_to_S parseVersion str, all isSpace s ] + -- ----------------------------------------------------------------------------- -- Version ranges @@ -207,6 +215,10 @@ | UnionVersionRanges VersionRange VersionRange | IntersectVersionRanges VersionRange VersionRange deriving (Show,Read,Eq) + +isAnyVersion :: VersionRange -> Bool +isAnyVersion AnyVersion = True +isAnyVersion _ = False orLaterVersion :: Version -> VersionRange orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,7 @@ -Copyright Isaac Jones 2003-2005. +Copyright (c) 2003-2007, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, Ian Lynagh, + Duncan Coutts, Thomas Schilling All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -74,12 +74,11 @@ | EmptyDataDecls | CPP + | KindSignatures | BangPatterns | TypeSynonymInstances | TemplateHaskell | ForeignFunctionInterface - | InlinePhase - | ContextStack | Arrows | Generics | NoImplicitPrelude @@ -90,4 +89,7 @@ | ExtensibleRecords | RestrictedTypeSynonyms | HereDocuments + | MagicHash + | TypeFamilies + | StandaloneDeriving deriving (Show, Read, Eq) diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,5 +1,8 @@ #!/usr/bin/runhaskell -> module Main where + +> module Main (main) where +> > import Distribution.Simple +> > main :: IO () > main = defaultMain diff --git a/mkGHCMakefile.sh b/mkGHCMakefile.sh new file mode 100644 --- /dev/null +++ b/mkGHCMakefile.sh @@ -0,0 +1,7 @@ +#!/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