Cabal 1.1.6 → 1.2.1
raw patch · 50 files changed
+9051/−5196 lines, 50 filesdep +containersdep +directorydep +filepathdep ~basesetup-changednew-uploader
Dependencies added: containers, directory, filepath, old-time, pretty, process, unix
Dependency ranges changed: base
Files
- Cabal.cabal +47/−15
- Distribution/Compat/Directory.hs +13/−8
- Distribution/Compat/FilePath.hs +0/−459
- Distribution/Compat/Map.hs +19/−0
- Distribution/Compat/TempFile.hs +61/−0
- Distribution/Compiler.hs +15/−164
- Distribution/Configuration.hs +460/−0
- Distribution/Extension.hs +1/−5
- Distribution/GetOpt.hs +35/−26
- Distribution/InstalledPackageInfo.hs +27/−23
- Distribution/License.hs +7/−6
- Distribution/Make.hs +78/−61
- Distribution/Package.hs +6/−3
- Distribution/PackageDescription.hs +1630/−851
- Distribution/ParseUtils.hs +539/−117
- Distribution/PreProcess.hs +0/−308
- Distribution/PreProcess/Unlit.hs +0/−106
- Distribution/Program.hs +0/−280
- Distribution/Setup.hs +4/−807
- Distribution/Simple.hs +365/−368
- Distribution/Simple/Build.hs +133/−69
- Distribution/Simple/Compiler.hs +127/−0
- Distribution/Simple/Configure.hs +349/−312
- Distribution/Simple/GHC.hs +403/−199
- Distribution/Simple/GHC/Makefile.hs +5/−0
- Distribution/Simple/GHC/Makefile.in +154/−0
- Distribution/Simple/GHC/PackageConfig.hs +169/−0
- Distribution/Simple/GHCPackageConfig.hs +0/−165
- Distribution/Simple/Haddock.hs +307/−0
- Distribution/Simple/Hugs.hs +134/−94
- Distribution/Simple/Install.hs +100/−50
- Distribution/Simple/InstallDirs.hs +501/−0
- Distribution/Simple/JHC.hs +86/−37
- Distribution/Simple/LocalBuildInfo.hs +76/−231
- Distribution/Simple/NHC.hs +56/−13
- Distribution/Simple/PreProcess.hs +464/−0
- Distribution/Simple/PreProcess/Unlit.hs +90/−0
- Distribution/Simple/Program.hs +628/−0
- Distribution/Simple/Register.hs +198/−168
- Distribution/Simple/Setup.hs +1024/−0
- Distribution/Simple/SetupWrapper.hs +164/−0
- Distribution/Simple/SrcDist.hs +138/−62
- Distribution/Simple/Utils.hs +282/−184
- Distribution/System.hs +14/−0
- Distribution/Verbosity.hs +110/−0
- Distribution/Version.hs +13/−1
- LICENSE +4/−1
- Language/Haskell/Extension.hs +4/−2
- Setup.lhs +4/−1
- mkGHCMakefile.sh +7/−0
Cabal.cabal view
@@ -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 <ijones@syntaxpolice.org>-Maintainer: Isaac Jones <ijones@syntaxpolice.org>+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
Distribution/Compat/Directory.hs view
@@ -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 ()
− Distribution/Compat/FilePath.hs
@@ -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
Distribution/Compat/Map.hs view
@@ -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
+ Distribution/Compat/TempFile.hs view
@@ -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)+
Distribution/Compiler.hs view
@@ -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
+ Distribution/Configuration.hs view
@@ -0,0 +1,460 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Configuration+-- Copyright : Thomas Schilling, 2007+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Configurations++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Configuration (+ Flag(..),+ ConfVar(..),+ Condition(..), parseCondition, simplifyCondition,+ CondTree(..), ppCondTree, mapTreeData,+ --satisfyFlags, + resolveWithFlags, ignoreConditions,+ DepTestRslt(..)+ ) where++import Distribution.Compat.ReadP as ReadP hiding ( char )+import qualified Distribution.Compat.ReadP as ReadP ( char )+import Distribution.Version + ( Version(..), VersionRange(..), withinRange+ , showVersionRange, parseVersionRange )++import Text.PrettyPrint.HughesPJ++import Data.Char ( isAlphaNum, toLower )+import Data.Maybe ( catMaybes, maybeToList )+import Data.Monoid++#ifdef DEBUG+import Data.List ( (\\) )+import Distribution.ParseUtils+#endif++------------------------------------------------------------------------------++-- | A flag can represent a feature to be included, or a way of linking+-- a target against its dependencies, or in fact whatever you can think of.+data Flag = MkFlag+ { flagName :: String+ , flagDescription :: String+ , flagDefault :: Bool+ }++instance Show Flag where show (MkFlag n _ _) = n++-- | A @ConfFlag@ represents an user-defined flag+data ConfFlag = ConfFlag String+ deriving Eq++-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS String + | Arch String + | Flag ConfFlag+ | Impl String VersionRange+ deriving Eq++instance Show ConfVar where+ show (OS n) = "os(" ++ n ++ ")"+ show (Arch n) = "arch(" ++ n ++ ")"+ show (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"+ show (Impl c v) = "impl(" ++ c ++ " " ++ showVersionRange v ++ ")"++-- | A boolean expression parameterized over the variable type used.+data Condition c = Var c+ | Lit Bool+ | CNot (Condition c)+ | COr (Condition c) (Condition c)+ | CAnd (Condition c) (Condition c)+ +instance Show c => Show (Condition c) where+ show c = render $ ppCond c++-- | Pretty print a @Condition@.+ppCond :: Show c => Condition c -> Doc+ppCond (Var x) = text (show x)+ppCond (Lit b) = text (show b)+ppCond (CNot c) = char '!' <> parens (ppCond c)+ppCond (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]+ppCond (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]+++-- | Simplify the condition and return its free variables.+simplifyCondition :: Condition c+ -> (c -> Either d Bool) -- ^ (partial) variable assignment+ -> (Condition d, [d])+simplifyCondition cond i = fv . walk $ cond+ where+ walk cnd = case cnd of+ Var v -> either Var Lit (i v)+ Lit b -> Lit b+ CNot c -> case walk c of+ Lit True -> Lit False+ Lit False -> Lit True+ c' -> CNot c'+ COr c d -> case (walk c, walk d) of+ (Lit False, d') -> d'+ (Lit True, _) -> Lit True+ (c', Lit False) -> c'+ (_, Lit True) -> Lit True+ (c',d') -> COr c' d'+ CAnd c d -> case (walk c, walk d) of+ (Lit False, _) -> Lit False+ (Lit True, d') -> d'+ (_, Lit False) -> Lit False+ (c', Lit True) -> c'+ (c',d') -> CAnd c' d'+ -- gather free vars+ fv c = (c, fv' c)+ fv' c = case c of+ Var v -> [v]+ Lit _ -> []+ CNot c' -> fv' c'+ COr c1 c2 -> fv' c1 ++ fv' c2+ CAnd c1 c2 -> fv' c1 ++ fv' c2++-- | Simplify a configuration condition using the os and arch names. Returns+-- the names of all the flags occurring in the condition.+simplifyWithSysParams :: String -> String -> (String, Version) -> Condition ConfVar -> + (Condition ConfFlag, [String])+simplifyWithSysParams os arch (impl, implVer) cond = (cond', flags)+ where+ (cond', fvs) = simplifyCondition cond interp + interp (OS name) = Right $ lcase name == lcase os+ || lcase name `elem` osAliases (lcase os)+ interp (Arch name) = Right $ lcase name == lcase arch+ interp (Impl i vr) = Right $ lcase impl == lcase i+ && implVer `withinRange` vr+ interp (Flag f) = Left f+ flags = [ fname | ConfFlag fname <- fvs ]++ --FIXME: use Distribution.System.OS type and alias list:+ osAliases "mingw32" = ["windows"]+ osAliases "solaris2" = ["solaris"]+ osAliases _ = []+ lcase = map toLower++-- XXX: Add instances and check+--+-- prop_sC_idempotent cond a o = cond' == cond''+-- where+-- cond' = simplifyCondition cond a o+-- cond'' = simplifyCondition cond' a o+--+-- prop_sC_noLits cond a o = isLit res || not (hasLits res)+-- where+-- res = simplifyCondition cond a o+-- hasLits (Lit _) = True+-- hasLits (CNot c) = hasLits c+-- hasLits (COr l r) = hasLits l || hasLits r+-- hasLits (CAnd l r) = hasLits l || hasLits r+-- hasLits _ = False+--++-- | Parse a configuration condition from a string.+parseCondition :: ReadP r (Condition ConfVar)+parseCondition = condOr+ where+ condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr+ condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd+ cond = sp >> (lit +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond )+ inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)+ notCond = ReadP.char '!' >> sp >> cond >>= return . CNot+ osCond = string "os" >> sp >> inparens osIdent >>= return . Var. OS + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var . Arch + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var . Flag . ConfFlag+ implCond = string "impl" >> sp >> inparens implIdent >>= return . Var+ ident = munch1 isIdentChar >>= return . map toLower+ lit = ((string "true" <++ string "True") >> return (Lit True)) <++ + ((string "false" <++ string "False") >> return (Lit False))+ archIdent = ident >>= return + osIdent = ident >>= return + flagIdent = ident+ isIdentChar c = isAlphaNum c || (c `elem` "_-")+ oper s = sp >> string s >> sp+ sp = skipSpaces+ implIdent = do i <- ident+ vr <- sp >> option AnyVersion parseVersionRange+ return $ Impl i vr++------------------------------------------------------------------------------++data CondTree v c a = CondNode + { condTreeData :: a+ , condTreeConstraints :: c+ , condTreeComponents :: [( Condition v+ , CondTree v c a+ , Maybe (CondTree v c a))]+ }++mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b+mapCondTree fa fc fcnd (CondNode a c ifs) =+ CondNode (fa a) (fc c) (map g ifs)+ where+ g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,+ fmap (mapCondTree fa fc fcnd) me)++mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a+mapTreeConstrs f = mapCondTree id f id++mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a+mapTreeConds f = mapCondTree id id f++mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b+mapTreeData f = mapCondTree f id id++instance (Show v, Show c) => Show (CondTree v c a) where+ show t = render $ ppCondTree t (text . show)++ppCondTree :: Show v => CondTree v c a -> (c -> Doc) -> Doc+ppCondTree (CondNode _dat cs ifs) ppD =+ (text "build-depends: " <+>+ ppD cs)+ $+$+ (vcat $ map ppIf ifs)+ where + ppIf (c,thenTree,mElseTree) = + ((text "if" <+> ppCond c <> colon) $$+ nest 2 (ppCondTree thenTree ppD))+ $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t ppD))+ mElseTree)++ +-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for+-- clarity.+data DepTestRslt d = DepOk | MissingDeps d ++instance Monoid d => Monoid (DepTestRslt d) where+ mempty = DepOk+ mappend DepOk x = x+ mappend x DepOk = x+ mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')+++data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree+++-- | Try to find a flag assignment that satisfies the constaints of all trees.+--+-- Returns either the missing dependencies, or a tuple containing the+-- resulting data, the associated dependencies, and the chosen flag+-- assignments.+--+-- In case of failure, the _smallest_ number of of missing dependencies is+-- returned. [XXX: Could also be specified with a function argument.]+--+-- XXX: The current algorithm is rather naive. A better approach would be to:+--+-- * Rule out possible paths, by taking a look at the associated dependencies.+--+-- * Infer the required values for the conditions of these paths, and+-- calculate the required domains for the variables used in these+-- conditions. Then picking a flag assignment would be linear (I guess).+--+-- This would require some sort of SAT solving, though, thus it's not+-- implemented unless we really need it.+-- +resolveWithFlags :: Monoid a =>+ [(String,[Bool])] + -- ^ Domain for each flag name, will be tested in order.+ -> String -- ^ OS name, as returned by System.Info.os+ -> String -- ^ arch name, as returned by System.Info.arch+ -> (String, Version) -- ^ Compiler name + version+ -> [CondTree ConfVar [d] a] + -> ([d] -> DepTestRslt [d]) -- ^ Dependency test function.+ -> (Either [d] -- missing dependencies+ ([a], [d], [(String, Bool)]))+resolveWithFlags dom os arch impl trees checkDeps =+ case try dom [] of+ Right r -> Right r+ Left dbt -> Left $ findShortest dbt+ where + -- Check dependencies only once; might avoid some duplicate efforts.+ preCheckedTrees = map ( mapTreeConstrs (\d -> (checkDeps d,d))+ . mapTreeConds (fst . simplifyWithSysParams os arch impl) )+ trees++ -- @try@ recursively tries all possible flag assignments in the domain and+ -- either succeeds or returns a binary tree with the missing dependencies+ -- encountered in each run. Since the tree is constructed lazily, we+ -- avoid some computation overhead in the successful case.+ try [] flags = + let (depss, as) = unzip + . map (simplifyCondTree (env flags)) + $ preCheckedTrees+ in case mconcat depss of+ (DepOk, ds) -> Right (as, ds, flags)+ (MissingDeps mds, _) -> Left (BTN mds)+ try ((n, vals):rest) flags = + tryAll $ map (\v -> try rest ((n, v):flags)) vals++ tryAll = foldr mp mz++ -- special version of `mplus' for our local purposes+ mp (Left xs) (Left ys) = (Left (BTB xs ys))+ mp (Left _) m@(Right _) = m+ mp m@(Right _) _ = m++ -- `mzero'+ mz = Left (BTN [])++ env flags flag@(ConfFlag n) = maybe (Left flag) Right . lookup n $ flags ++ -- for the error case we inspect our lazy tree of missing dependencies and+ -- pick the shortest list of missing dependencies+ findShortest (BTN x) = x+ findShortest (BTB lt rt) = + let l = findShortest lt+ r = findShortest rt+ in case (l,r) of+ ([], xs) -> xs -- [] is too short+ (xs, []) -> xs+ ([x], _) -> [x] -- single elem is optimum+ (_, [x]) -> [x]+ (xs, ys) -> if lazyLengthCmp xs ys+ then xs else ys + -- lazy variant of @\xs ys -> length xs <= length ys@+ lazyLengthCmp [] _ = True+ lazyLengthCmp _ [] = False+ lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys++++simplifyCondTree :: (Monoid a, Monoid d) =>+ (v -> Either v Bool) + -> CondTree v d a + -> (d, a)+simplifyCondTree env (CondNode a d ifs) =+ foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs+ where+ simplifyIf (cnd, t, me) = + case simplifyCondition cnd env of+ (Lit True, _) -> Just $ simplifyCondTree env t+ (Lit False, _) -> fmap (simplifyCondTree env) me+ _ -> error $ "Environment not defined for all free vars" ++-- | Flatten a CondTree. This will resolve the CondTree by taking all+-- possible paths into account. Note that since branches represent exclusive+-- choices this may not result in a "sane" result.+ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)+ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)+ where f (_, t, me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me)++------------------------------------------------------------------------------+-- compatibility++#if (__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ <= 602)+-- This instance wasn't present in Data.Monoid in GHC 6.2+instance (Monoid a, Monoid b) => Monoid (a,b) where+ mempty = (mempty, mempty)+ (a1,b1) `mappend` (a2,b2) =+ (a1 `mappend` a2, b1 `mappend` b2)+#endif++------------------------------------------------------------------------------+-- Testing++#ifdef DEBUG++tstTree :: CondTree ConfVar [Int] String+tstTree = CondNode "A" [0] + [ (CNot (Var (Flag (ConfFlag "a"))), + CondNode "B" [1] [],+ Nothing)+ , (CAnd (Var (Flag (ConfFlag "b"))) (Var (Flag (ConfFlag "c"))),+ CondNode "C" [2] [],+ Just $ CondNode "D" [3] + [ (Lit True,+ CondNode "E" [4] [],+ Just $ CondNode "F" [5] []) ])+ ]+++test_simplify = simplifyWithSysParams i386 darwin ("ghc",Version [6,6] []) tstCond + where + tstCond = COr (CAnd (Var (Arch ppc)) (Var (OS darwin)))+ (CAnd (Var (Flag (ConfFlag "debug"))) (Var (OS darwin)))+ [ppc,i386] = ["ppc","i386"]+ [darwin,windows] = ["darwin","windows"]++++test_parseCondition = map (runP 1 "test" parseCondition) testConditions+ where+ testConditions = [ "os(darwin)"+ , "arch(i386)"+ , "!os(linux)"+ , "! arch(ppc)"+ , "os(windows) && arch(i386)"+ , "os(windows) && arch(i386) && flag(debug)"+ , "true && false || false && true" -- should be same + , "(true && false) || (false && true)" -- as this+ , "(os(darwin))"+ , " ( os ( darwin ) ) "+ , "true && !(false || os(plan9))"+ , "flag( foo_bar )"+ , "flag( foo_O_-_O_bar )"+ , "impl ( ghc )"+ , "impl( ghc >= 6.6.1 )"+ ]++test_ppCondTree = render $ ppCondTree tstTree (text . show)+ ++test_simpCondTree = simplifyCondTree env tstTree+ where+ env x = maybe (Left x) Right (lookup x flags)+ flags = [(mkFlag "a",False), (mkFlag "b",False), (mkFlag "c", True)] + mkFlag = Flag . ConfFlag++test_resolveWithFlags = resolveWithFlags dom "os" "arch" ("ghc",Version [6,6] []) [tstTree] check+ where+ dom = [("a", [False,True]), ("b", [True,False]), ("c", [True,False])]+ check ds = let missing = ds \\ avail in+ case missing of+ [] -> DepOk+ _ -> MissingDeps missing+ avail = [0,1,3,4]++test_ignoreConditions = ignoreConditions tstTree++#endif
Distribution/Extension.hs view
@@ -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(..))
Distribution/GetOpt.hs view
@@ -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
Distribution/InstalledPackageInfo.hs view
@@ -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+
Distribution/License.hs view
@@ -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.
Distribution/Make.hs view
@@ -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
Distribution/Package.hs view
@@ -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
Distribution/PackageDescription.hs view
@@ -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+
Distribution/ParseUtils.hs view
@@ -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 @<property>: <value>@ field+ | Section LineNo String String [Field]+ -- ^ A section with a name and possible parameter. The syntactic+ -- structure is:+ -- + -- @+ -- <sectionname> <arg> {+ -- <field>*+ -- }+ -- @+ | IfBlock LineNo String [Field] [Field]+ -- ^ A conditional block with an optional else branch:+ --+ -- @+ -- if <condition> {+ -- <field>*+ -- } else {+ -- <field>*+ -- }+ -- @+ 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
− Distribution/PreProcess.hs
@@ -1,308 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.PreProcess--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- 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)- ]
− Distribution/PreProcess/Unlit.hs
@@ -1,106 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.PreProcess.Unlit--- Copyright : ...--- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>--- 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 _ = ""--}-
− Distribution/Program.hs
@@ -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
Distribution/Setup.hs view
@@ -1,808 +1,5 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- Module : Distribution.Setup--- Copyright : Isaac Jones 2003-2004--- --- Maintainer : Isaac Jones <ijones@syntaxpolice.org>--- Stability : alpha--- Portability : portable------ Explanation: Data types and parser for the standard command-line--- setup. Will also return commands it doesn't know about.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Isaac Jones nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.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
Distribution/Simple.hs view
@@ -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
Distribution/Simple/Build.hs view
@@ -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_<pkg>.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_<pkg>.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
+ Distribution/Simple/Compiler.hs view
@@ -0,0 +1,127 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Compiler+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- 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
Distribution/Simple/Configure.hs view
@@ -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
Distribution/Simple/GHC.hs view
@@ -2,12 +2,15 @@ ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC--- Copyright : Isaac Jones 2003-2006+-- Copyright : Isaac Jones 2003-2007 -- -- Maintainer : Isaac Jones <ijones@syntaxpolice.org> -- 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
+ Distribution/Simple/GHC/Makefile.hs view
@@ -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",""]+}
+ Distribution/Simple/GHC/Makefile.in view
@@ -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+
+ Distribution/Simple/GHC/PackageConfig.hs view
@@ -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)))
− Distribution/Simple/GHCPackageConfig.hs
@@ -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)))
+ Distribution/Simple/Haddock.hs view
@@ -0,0 +1,307 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Haddock+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- 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"])
Distribution/Simple/Hugs.hs view
@@ -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 <copy-prefix>/lib/hugs/packages/<pkgname>--- (i.e. <prefix>/lib/hugs/packages/<pkgname> on the target system).--- Each executable goes in <copy-prefix>/lib/hugs/programs/<exename>--- (i.e. <prefix>/lib/hugs/programs/<exename> on the target system)--- with a script <copy-prefix>/bin/<exename> pointing at--- <prefix>/lib/hugs/programs/<exename>+-- The library goes in \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>+-- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).+-- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>+-- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)+-- with a script \<copy-prefix>\/bin\/\<exename> pointing at+-- \<prefix>\/lib\/hugs\/programs\/\<exename>. 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)
Distribution/Simple/Install.hs view
@@ -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
+ Distribution/Simple/InstallDirs.hs view
@@ -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 <ijones@syntaxpolice.org>+-- 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
Distribution/Simple/JHC.hs view
@@ -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)+
Distribution/Simple/LocalBuildInfo.hs view
@@ -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" #-}
Distribution/Simple/NHC.hs view
@@ -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)
+ Distribution/Simple/PreProcess.hs view
@@ -0,0 +1,464 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.PreProcess+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- 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)+ ]
+ Distribution/Simple/PreProcess/Unlit.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.PreProcess.Unlit+-- Copyright : ...+-- +-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>+-- 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:))+
+ Distribution/Simple/Program.hs view
@@ -0,0 +1,628 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Program+-- Copyright : Isaac Jones 2006+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : GHC, Hugs+--+-- Explanation: A program is basically a name, a location, and some+-- arguments.+--+-- 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+ }
Distribution/Simple/Register.hs view
@@ -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
+ Distribution/Simple/Setup.hs view
@@ -0,0 +1,1024 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Setup+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Data types and parser for the standard command-line+-- setup. Will also return commands it doesn't know about.++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Simple.Setup (--parseArgs,+ module Distribution.Simple.Compiler,+ Action(..),+ ConfigFlags(..), emptyConfigFlags, configureArgs,+ CopyFlags(..), CopyDest(..), emptyCopyFlags,+ InstallFlags(..), emptyInstallFlags,+ HaddockFlags(..), emptyHaddockFlags,+ HscolourFlags(..), emptyHscolourFlags,+ BuildFlags(..), emptyBuildFlags,+ CleanFlags(..), emptyCleanFlags,+ PFEFlags(..),+ MakefileFlags(..), emptyMakefileFlags,+ RegisterFlags(..), emptyRegisterFlags,+ SDistFlags(..),+ --optionHelpString,+#ifdef DEBUG+ hunitTests,+#endif+ parseGlobalArgs,+ parseConfigureArgs, parseBuildArgs, parseCleanArgs,+ parseMakefileArgs,+ parseHscolourArgs, parseHaddockArgs, parseProgramaticaArgs, parseTestArgs,+ parseInstallArgs, parseSDistArgs, parseRegisterArgs,+ parseUnregisterArgs, parseCopyArgs,+ reqPathArg, reqDirArg+ ) where+++-- Misc:+#ifdef DEBUG+import Test.HUnit (Test(..))+#endif++import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..),+ defaultCompilerFlavor, PackageDB(..))+import Distribution.Simple.Utils (die, wrapText)+import Distribution.Simple.Program (Program(..), ProgramConfiguration,+ knownPrograms, userSpecifyPath, userSpecifyArgs)+import Data.List (find, sort)+import Data.Char( toLower, isSpace )+import Distribution.GetOpt+import Distribution.Verbosity+import System.Exit+import System.Environment++-- type CommandLineOpts = (Action,+-- [String]) -- The un-parsed remainder++data Action = ConfigCmd ConfigFlags -- config+ | BuildCmd -- build+ | CleanCmd -- clean+ | CopyCmd CopyDest -- copy (--destdir flag)+ | HscolourCmd -- hscolour+ | HaddockCmd -- haddock+ | ProgramaticaCmd -- pfesetup+ | InstallCmd -- install (install-prefix)+ | SDistCmd -- sdist+ | MakefileCmd -- makefile+ | TestCmd -- test+ | RegisterCmd -- register+ | UnregisterCmd -- unregister+ | HelpCmd -- help+-- | NoCmd -- error case, help case.+-- | BDist -- 1.0+ deriving Show++-- ------------------------------------------------------------+-- * Flag-related types+-- ------------------------------------------------------------++-- | Flags to @configure@ command+data ConfigFlags = ConfigFlags {+ configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run+ configHcFlavor :: Maybe CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.+ configHcPath :: Maybe FilePath, -- ^given compiler location+ configHcPkg :: Maybe FilePath, -- ^given hc-pkg location+ configVanillaLib :: Bool, -- ^Enable vanilla library+ configProfLib :: Bool, -- ^Enable profiling in the library+ configSharedLib :: Bool, -- ^Build shared library+ configProfExe :: Bool, -- ^Enable profiling in the executables.+ configConfigureArgs :: [String], -- ^Extra arguments to @configure@+ configOptimization :: Bool, -- ^Enable optimization.+ configPrefix :: Maybe FilePath,+ -- ^installation prefix+ configBinDir :: Maybe FilePath, + -- ^installation dir for binaries,+ configLibDir :: Maybe FilePath, + -- ^installation dir for object code libraries, + configLibSubDir :: Maybe FilePath,+ -- ^subdirectory of libdir in which libs are installed+ configLibExecDir :: Maybe FilePath,+ -- ^installation dir for program executables,+ configDataDir :: Maybe FilePath,+ -- ^installation dir for read-only arch-independent data,+ configDataSubDir :: Maybe FilePath,+ -- ^subdirectory of datadir in which data files are installed+ configDocDir :: Maybe FilePath,+ -- ^installation dir for documentation+ configHtmlDir :: Maybe FilePath,+ -- ^installation dir for HTML documentation++ 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?+-}+
+ Distribution/Simple/SetupWrapper.hs view
@@ -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]
Distribution/Simple/SrcDist.hs view
@@ -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 ------------------------------------------------------------
Distribution/Simple/Utils.hs view
@@ -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<packagename>-<compilerFlavour><compilerVersion>+-- e.g. libHSbase-2.1-ghc6.6.1.so+mkSharedLibName :: FilePath -- ^file Prefix+ -> String -- ^library name.+ -> PackageIdentifier -- ^package identifier of the compiler+ -> String+mkSharedLibName pref lib (PackageIdentifier compilerName compilerVersion)+ = pref </> ("libHS" ++ lib ++ "-" ++ compiler) <.> dllExtension+ where compiler = compilerName ++ showVersion compilerVersion -- ------------------------------------------------------------ -- * Finding the description file@@ -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 <pkgname>." ++ cabalExt+ = do warn verbosity $ "The filename \"Setup.description\" is deprecated, please move to <pkgname>." ++ 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 -- <pkgname>.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
+ Distribution/System.hs view
@@ -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
+ Distribution/Verbosity.hs view
@@ -0,0 +1,110 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Verbosity+-- Copyright : Ian Lynagh 2007+--+-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- 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
Distribution/Version.hs view
@@ -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)
LICENSE view
@@ -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
Language/Haskell/Extension.hs view
@@ -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)
Setup.lhs view
@@ -1,5 +1,8 @@ #!/usr/bin/runhaskell-> module Main where++> module Main (main) where+> > import Distribution.Simple+> > main :: IO () > main = defaultMain
+ mkGHCMakefile.sh view
@@ -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