Cabal (empty) → 1.1.6
raw patch · 37 files changed
+9797/−0 lines, 37 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- Cabal.cabal +57/−0
- Distribution/Compat/Directory.hs +136/−0
- Distribution/Compat/Exception.hs +15/−0
- Distribution/Compat/FilePath.hs +459/−0
- Distribution/Compat/Map.hs +67/−0
- Distribution/Compat/RawSystem.hs +17/−0
- Distribution/Compat/ReadP.hs +483/−0
- Distribution/Compiler.hs +210/−0
- Distribution/Extension.hs +51/−0
- Distribution/GetOpt.hs +326/−0
- Distribution/InstalledPackageInfo.hs +287/−0
- Distribution/License.hs +67/−0
- Distribution/Make.hs +195/−0
- Distribution/Package.hs +77/−0
- Distribution/PackageDescription.hs +896/−0
- Distribution/ParseUtils.hs +312/−0
- Distribution/PreProcess.hs +308/−0
- Distribution/PreProcess/Unlit.hs +106/−0
- Distribution/Program.hs +280/−0
- Distribution/Setup.hs +808/−0
- Distribution/Simple.hs +692/−0
- Distribution/Simple/Build.hs +282/−0
- Distribution/Simple/Configure.hs +486/−0
- Distribution/Simple/GHC.hs +435/−0
- Distribution/Simple/GHCPackageConfig.hs +165/−0
- Distribution/Simple/Hugs.hs +355/−0
- Distribution/Simple/Install.hs +133/−0
- Distribution/Simple/JHC.hs +123/−0
- Distribution/Simple/LocalBuildInfo.hs +324/−0
- Distribution/Simple/NHC.hs +66/−0
- Distribution/Simple/Register.hs +379/−0
- Distribution/Simple/SrcDist.hs +188/−0
- Distribution/Simple/Utils.hs +517/−0
- Distribution/Version.hs +367/−0
- LICENSE +30/−0
- Language/Haskell/Extension.hs +93/−0
- Setup.lhs +5/−0
+ Cabal.cabal view
@@ -0,0 +1,57 @@+Name: Cabal+Version: 1.1.6+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>+Homepage: http://www.haskell.org/cabal/+Synopsis: A framework for packaging Haskell software+Description:+ The Haskell Common Architecture for Building Applications and+ Libraries: a framework defining a common interface for authors to more+ easily build their Haskell applications in a portable way.+ .+ The Haskell Cabal is meant to be a part of a larger infrastructure+ for distributing, organizing, and cataloging Haskell libraries+ and tools.+Category: Distribution+Exposed-Modules:+ Distribution.Compiler,+ Distribution.Extension,+ Distribution.InstalledPackageInfo,+ Distribution.License,+ Distribution.Make,+ Distribution.Program,+ Distribution.Package,+ Distribution.PackageDescription,+ Distribution.ParseUtils,+ Distribution.PreProcess,+ Distribution.PreProcess.Unlit,+ Distribution.Setup,+ Distribution.Simple,+ Distribution.Simple.Build,+ Distribution.Simple.Configure,+ Distribution.Simple.GHC,+ Distribution.Simple.GHCPackageConfig,+ Distribution.Simple.Hugs,+ Distribution.Simple.Install,+ Distribution.Simple.JHC,+ Distribution.Simple.LocalBuildInfo,+ Distribution.Simple.NHC,+ Distribution.Simple.Register,+ Distribution.Simple.SrcDist,+ Distribution.Simple.Utils,+ Distribution.Version,+ Language.Haskell.Extension,+ Distribution.Compat.FilePath+Other-Modules:+ Distribution.GetOpt,+ Distribution.Compat.Map,+ Distribution.Compat.Directory,+ Distribution.Compat.Exception,+ Distribution.Compat.RawSystem,+ Distribution.Compat.ReadP+Extensions: CPP
+ Distribution/Compat/Directory.hs view
@@ -0,0 +1,136 @@+{-# OPTIONS -cpp #-}+-- #hide+module Distribution.Compat.Directory (+ module System.Directory,+#if __GLASGOW_HASKELL__ <= 602+ findExecutable, copyFile, getHomeDirectory, createDirectoryIfMissing,+ removeDirectoryRecursive,+#endif+ getDirectoryContentsWithoutSpecial+ ) where++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604+#if __GLASGOW_HASKELL__ < 603+#include "config.h"+#else+#include "ghcconfig.h"+#endif+#endif++#if !__GLASGOW_HASKELL__ || __GLASGOW_HASKELL__ > 602++import System.Directory++#else /* to end of file... */++import System.Environment ( getEnv )+import Distribution.Compat.FilePath+import System.IO+import Foreign+import System.Directory+import Distribution.Compat.Exception (bracket)+import Control.Monad (when, unless)+#if !(mingw32_HOST_OS || mingw32_TARGET_OS)+import System.Posix (getFileStatus,setFileMode,fileMode,accessTime,+ setFileMode,modificationTime,setFileTimes)+#endif++findExecutable :: String -> IO (Maybe FilePath)+findExecutable binary = do+ path <- getEnv "PATH"+ search (parseSearchPath path)+ where+ search :: [FilePath] -> IO (Maybe FilePath)+ search [] = return Nothing+ search (d:ds) = do+ let path = d `joinFileName` binary `joinFileExt` exeSuffix+ b <- doesFileExist path+ if b then return (Just path)+ else search ds++exeSuffix :: String+#if mingw32_HOST_OS || mingw32_TARGET_OS+exeSuffix = "exe"+#else+exeSuffix = ""+#endif++copyPermissions :: FilePath -> FilePath -> IO ()+#if !(mingw32_HOST_OS || mingw32_TARGET_OS)+copyPermissions src dest+ = do srcStatus <- getFileStatus src+ setFileMode dest (fileMode srcStatus)+#else+copyPermissions src dest+ = getPermissions src >>= setPermissions dest+#endif+++copyFileTimes :: FilePath -> FilePath -> IO ()+#if !(mingw32_HOST_OS || mingw32_TARGET_OS)+copyFileTimes src dest+ = do st <- getFileStatus src+ let atime = accessTime st+ mtime = modificationTime st+ setFileTimes dest atime mtime+#else+copyFileTimes src dest+ = return ()+#endif++-- |Preserves permissions and, if possible, atime+mtime+copyFile :: FilePath -> FilePath -> IO ()+copyFile src dest + | dest == src = fail "copyFile: source and destination are the same file"+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))+ | otherwise = do readFile src >>= writeFile dest+ try (copyPermissions src dest)+ return ()+#else+ | otherwise = bracket (openBinaryFile src ReadMode) hClose $ \hSrc ->+ bracket (openBinaryFile dest WriteMode) hClose $ \hDest ->+ do allocaBytes bufSize $ \buffer -> copyContents hSrc hDest buffer+ try (copyPermissions src dest)+ try (copyFileTimes src dest)+ return ()+ where bufSize = 1024+ copyContents hSrc hDest buffer+ = do count <- hGetBuf hSrc buffer bufSize+ when (count > 0) $ do hPutBuf hDest buffer count+ copyContents hSrc hDest buffer+#endif++getHomeDirectory :: IO FilePath+getHomeDirectory = getEnv "HOME"++createDirectoryIfMissing :: Bool -- ^ Create its parents too?+ -> FilePath -- ^ The path to the directory you want to make+ -> IO ()+createDirectoryIfMissing parents file = do+ b <- doesDirectoryExist file+ case (b,parents, file) of + (_, _, "") -> return ()+ (True, _, _) -> return ()+ (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))+ (_, False, _) -> createDirectory file++removeDirectoryRecursive :: FilePath -> IO ()+removeDirectoryRecursive startLoc = do+ cont <- getDirectoryContentsWithoutSpecial startLoc+ mapM_ (rm . joinFileName startLoc) cont+ removeDirectory startLoc+ where+ rm :: FilePath -> IO ()+ rm f = do temp <- try (removeFile f)+ case temp of+ Left e -> do isDir <- doesDirectoryExist f+ -- If f is not a directory, re-throw the error+ unless isDir $ ioError e+ removeDirectoryRecursive f+ Right _ -> return ()++#endif++getDirectoryContentsWithoutSpecial :: FilePath -> IO [FilePath]+getDirectoryContentsWithoutSpecial =+ fmap (filter (not . flip elem [".", ".."])) . getDirectoryContents
+ Distribution/Compat/Exception.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS -cpp #-}+-- #hide+module Distribution.Compat.Exception (bracket,finally) where++#ifdef __NHC__+import System.IO.Error (catch, ioError)+import IO (bracket)+#else+import Control.Exception (bracket,finally)+#endif++#ifdef __NHC__+finally :: IO a -> IO b -> IO a+finally thing after = bracket (return ()) (const after) (const thing)+#endif
+ Distribution/Compat/FilePath.hs view
@@ -0,0 +1,459 @@+{-# 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
@@ -0,0 +1,67 @@+{-# OPTIONS -cpp #-}+-- #hide+module Distribution.Compat.Map (+ Map,+ member, lookup, findWithDefault,+ empty,+ insert, insertWith,+ union, unionWith, unions,+ elems, keys,+ fromList, fromListWith,+ toAscList+) where++import Prelude hiding ( lookup )++#if __GLASGOW_HASKELL__ >= 603 || !__GLASGOW_HASKELL__+import Data.Map+#else+import Data.FiniteMap++type Map k a = FiniteMap k a++instance Functor (FiniteMap k) where+ fmap f = mapFM (const f)++member :: Ord k => k -> Map k a -> Bool+member = elemFM++lookup :: Ord k => k -> Map k a -> Maybe a+lookup = flip lookupFM++findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault a k m = lookupWithDefaultFM m a k++empty :: Map k a+empty = emptyFM++insert :: Ord k => k -> a -> Map k a -> Map k a+insert k a m = addToFM m k a++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++union :: Ord k => Map k a -> Map k a -> Map k a+union = flip plusFM++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith c l r = plusFM_C (flip c) r l++unions :: Ord k => [Map k a] -> Map k a+unions = foldl (flip plusFM) emptyFM++elems :: Map k a -> [a]+elems = eltsFM++keys :: Map k a -> [k]+keys = keysFM++fromList :: Ord k => [(k,a)] -> Map k a+fromList = listToFM++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith c = addListToFM_C (flip c) emptyFM++toAscList :: Map k a -> [(k,a)]+toAscList = fmToList+#endif
+ Distribution/Compat/RawSystem.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS -cpp #-}+-- #hide+module Distribution.Compat.RawSystem (rawSystem) where++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 602+import Data.List (intersperse)+import System.Cmd (system)+import System.Exit (ExitCode)+#else+import System.Cmd (rawSystem)+#endif++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 602+rawSystem :: String -> [String] -> IO ExitCode+rawSystem p args = system $ concat $ intersperse " " (p : map esc args)+ where esc arg = "'" ++ arg ++ "'" -- this is hideously broken, actually+#endif
+ Distribution/Compat/ReadP.hs view
@@ -0,0 +1,483 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Compat.ReadP+-- Copyright : (c) The University of Glasgow 2002+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- This is a library of parser combinators, originally written by Koen Claessen.+-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with+-- other parsers. The '(+++)' choice combinator is genuinely commutative;+-- it makes no difference which branch is \"shorter\".+--+-- See also Koen's paper /Parallel Parsing Processes/+-- (<http://www.cs.chalmers.se/~koen/publications.html>).+--+-- This version of ReadP has been locally hacked to make it H98, by+-- Martin Sjögren <mailto:msjogren@gmail.com>+--+-----------------------------------------------------------------------------++module Distribution.Compat.ReadP+ ( + -- * The 'ReadP' type+ ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus+ + -- * Primitive operations+ get, -- :: ReadP Char+ look, -- :: ReadP String+ (+++), -- :: ReadP a -> ReadP a -> ReadP a+ (<++), -- :: ReadP a -> ReadP a -> ReadP a+ gather, -- :: ReadP a -> ReadP (String, a)+ + -- * Other operations+ pfail, -- :: ReadP a+ satisfy, -- :: (Char -> Bool) -> ReadP Char+ char, -- :: Char -> ReadP Char+ string, -- :: String -> ReadP String+ munch, -- :: (Char -> Bool) -> ReadP String+ munch1, -- :: (Char -> Bool) -> ReadP String+ skipSpaces, -- :: ReadP ()+ choice, -- :: [ReadP a] -> ReadP a+ count, -- :: Int -> ReadP a -> ReadP [a]+ between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a+ option, -- :: a -> ReadP a -> ReadP a+ optional, -- :: ReadP a -> ReadP ()+ many, -- :: ReadP a -> ReadP [a]+ many1, -- :: ReadP a -> ReadP [a]+ skipMany, -- :: ReadP a -> ReadP ()+ skipMany1, -- :: ReadP a -> ReadP ()+ sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]+ sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]+ endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]+ endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]+ chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+ chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+ chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+ chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+ manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]+ + -- * Running a parser+ ReadS, -- :: *; = String -> [(a,String)]+ readP_to_S, -- :: ReadP a -> ReadS a+ readS_to_P -- :: ReadS a -> ReadP a+ +#if __GLASGOW_HASKELL__ < 603 && !__HUGS__+ -- * Properties+ -- $properties+#endif+ )+ where++#if __GLASGOW_HASKELL__ >= 603 || __HUGS__++import Text.ParserCombinators.ReadP hiding (ReadP)+import qualified Text.ParserCombinators.ReadP as ReadP++type ReadP r a = ReadP.ReadP a++#else++import Control.Monad( MonadPlus(..), liftM2 )+import Data.Char (isSpace)++infixr 5 +++, <++++-- ---------------------------------------------------------------------------+-- The P type+-- is representation type -- should be kept abstract++data P s a+ = Get (s -> P s a)+ | Look ([s] -> P s a)+ | Fail+ | Result a (P s a)+ | Final [(a,[s])] -- invariant: list is non-empty!++-- Monad, MonadPlus++instance Monad (P s) where+ return x = Result x Fail++ (Get f) >>= k = Get (\c -> f c >>= k)+ (Look f) >>= k = Look (\s -> f s >>= k)+ Fail >>= k = Fail+ (Result x p) >>= k = k x `mplus` (p >>= k)+ (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]++ fail _ = Fail++instance MonadPlus (P s) where+ mzero = Fail++ -- most common case: two gets are combined+ Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)+ + -- results are delivered as soon as possible+ Result x p `mplus` q = Result x (p `mplus` q)+ p `mplus` Result x q = Result x (p `mplus` q)++ -- fail disappears+ Fail `mplus` p = p+ p `mplus` Fail = p++ -- two finals are combined+ -- final + look becomes one look and one final (=optimization)+ -- final + sthg else becomes one look and one final+ Final r `mplus` Final t = Final (r ++ t)+ Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))+ Final r `mplus` p = Look (\s -> Final (r ++ run p s))+ Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))+ p `mplus` Final r = Look (\s -> Final (run p s ++ r))++ -- two looks are combined (=optimization)+ -- look + sthg else floats upwards+ Look f `mplus` Look g = Look (\s -> f s `mplus` g s)+ Look f `mplus` p = Look (\s -> f s `mplus` p)+ p `mplus` Look f = Look (\s -> p `mplus` f s)++-- ---------------------------------------------------------------------------+-- The ReadP type++newtype Parser r s a = R ((a -> P s r) -> P s r)+type ReadP r a = Parser r Char a++-- Functor, Monad, MonadPlus++instance Functor (Parser r s) where+ fmap h (R f) = R (\k -> f (k . h))++instance Monad (Parser r s) where+ return x = R (\k -> k x)+ fail _ = R (\_ -> Fail)+ R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))++instance MonadPlus (Parser r s) where+ mzero = pfail+ mplus = (+++)++-- ---------------------------------------------------------------------------+-- Operations over P++final :: [(a,[s])] -> P s a+-- Maintains invariant for Final constructor+final [] = Fail+final r = Final r++--run :: P s a -> ReadS a+run (Get f) (c:s) = run (f c) s+run (Look f) s = run (f s) s+run (Result x p) s = (x,s) : run p s+run (Final r) _ = r+run _ _ = []++-- ---------------------------------------------------------------------------+-- Operations over ReadP++--get :: ReadP Char+-- ^ Consumes and returns the next character.+-- Fails if there is no input left.+get = R Get++--look :: ReadP String+-- ^ Look-ahead: returns the part of the input that is left, without+-- consuming it.+look = R Look++--pfail :: ReadP a+-- ^ Always fails.+pfail = R (\_ -> Fail)++--(+++) :: ReadP r a -> ReadP r a -> ReadP r a+-- ^ Symmetric choice.+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)++--(<++) :: ReadP a -> ReadP a -> ReadP a+-- ^ Local, exclusive, left-biased choice: If left parser+-- locally produces any result at all, then right parser is+-- not used.+R f <++ q =+ do s <- look+ probe (f return) s 0+ where+ probe (Get f) (c:s) n = probe (f c) s (n+1)+ probe (Look f) s n = probe (f s) s n+ probe p@(Result _ _) _ n = discard n >> R (p >>=)+ probe (Final r) _ _ = R (Final r >>=)+ probe _ _ _ = q++ discard 0 = return ()+ discard n = get >> discard (n-1)++--gather :: ReadP a -> ReadP (String, a)+-- ^ Transforms a parser into one that does the same, but+-- in addition returns the exact characters read.+-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument+-- is built using any occurrences of readS_to_P. +gather (R m) =+ R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where+ gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))+ gath l Fail = Fail+ gath l (Look f) = Look (\s -> gath l (f s))+ gath l (Result k p) = k (l []) `mplus` gath l p+ gath l (Final r) = error "do not use readS_to_P in gather!"++-- ---------------------------------------------------------------------------+-- Derived operations++--satisfy :: (Char -> Bool) -> ReadP Char+-- ^ Consumes and returns the next character, if it satisfies the+-- specified predicate.+satisfy p = do c <- get; if p c then return c else pfail++--char :: Char -> ReadP Char+-- ^ Parses and returns the specified character.+char c = satisfy (c ==)++--string :: String -> ReadP String+-- ^ Parses and returns the specified string.+string this = do s <- look; scan this s+ where+ scan [] _ = do return this+ scan (x:xs) (y:ys) | x == y = do get; scan xs ys+ scan _ _ = do pfail++--munch :: (Char -> Bool) -> ReadP String+-- ^ Parses the first zero or more characters satisfying the predicate.+munch p =+ do s <- look+ scan s+ where+ scan (c:cs) | p c = do get; s <- scan cs; return (c:s)+ scan _ = do return ""++--munch1 :: (Char -> Bool) -> ReadP String+-- ^ Parses the first one or more characters satisfying the predicate.+munch1 p =+ do c <- get+ if p c then do s <- munch p; return (c:s) else pfail++--choice :: [ReadP a] -> ReadP a+-- ^ Combines all parsers in the specified list.+choice [] = pfail+choice [p] = p+choice (p:ps) = p +++ choice ps++--skipSpaces :: ReadP ()+-- ^ Skips all whitespace.+skipSpaces =+ do s <- look+ skip s+ where+ skip (c:s) | isSpace c = do get; skip s+ skip _ = do return ()++--count :: Int -> ReadP a -> ReadP [a]+-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of+-- results is returned.+count n p = sequence (replicate n p)++--between :: ReadP open -> ReadP close -> ReadP a -> ReadP a+-- ^ @ between open close p @ parses @open@, followed by @p@ and finally+-- @close@. Only the value of @p@ is returned.+between open close p = do open+ x <- p+ close+ return x++--option :: a -> ReadP a -> ReadP a+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming+-- any input.+option x p = p +++ return x++--optional :: ReadP a -> ReadP ()+-- ^ @optional p@ optionally parses @p@ and always returns @()@.+optional p = (p >> return ()) +++ return ()++--many :: ReadP a -> ReadP [a]+-- ^ Parses zero or more occurrences of the given parser.+many p = return [] +++ many1 p++--many1 :: ReadP a -> ReadP [a]+-- ^ Parses one or more occurrences of the given parser.+many1 p = liftM2 (:) p (many p)++--skipMany :: ReadP a -> ReadP ()+-- ^ Like 'many', but discards the result.+skipMany p = many p >> return ()++--skipMany1 :: ReadP a -> ReadP ()+-- ^ Like 'many1', but discards the result.+skipMany1 p = p >> skipMany p++--sepBy :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.+-- Returns a list of values returned by @p@.+sepBy p sep = sepBy1 p sep +++ return []++--sepBy1 :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.+-- Returns a list of values returned by @p@.+sepBy1 p sep = liftM2 (:) p (many (sep >> p))++--endBy :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended+-- by @sep@.+endBy p sep = many (do x <- p ; sep ; return x)++--endBy1 :: ReadP a -> ReadP sep -> ReadP [a]+-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended+-- by @sep@.+endBy1 p sep = many1 (do x <- p ; sep ; return x)++--chainr :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+-- Returns a value produced by a /right/ associative application of all+-- functions returned by @op@. If there are no occurrences of @p@, @x@ is+-- returned.+chainr p op x = chainr1 p op +++ return x++--chainl :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.+-- Returns a value produced by a /left/ associative application of all+-- functions returned by @op@. If there are no occurrences of @p@, @x@ is+-- returned.+chainl p op x = chainl1 p op +++ return x++--chainr1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+-- ^ Like 'chainr', but parses one or more occurrences of @p@.+chainr1 p op = scan+ where scan = p >>= rest+ rest x = do f <- op+ y <- scan+ return (f x y)+ +++ return x++--chainl1 :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+-- ^ Like 'chainl', but parses one or more occurrences of @p@.+chainl1 p op = p >>= rest+ where rest x = do f <- op+ y <- p+ rest (f x y)+ +++ return x++--manyTill :: ReadP a -> ReadP end -> ReadP [a]+-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@+-- succeeds. Returns a list of values returned by @p@.+manyTill p end = scan+ where scan = (end >> return []) <++ (liftM2 (:) p scan)++-- ---------------------------------------------------------------------------+-- Converting between ReadP and Read++--readP_to_S :: ReadP a -> ReadS a+-- ^ Converts a parser into a Haskell ReadS-style function.+-- This is the main way in which you can \"run\" a 'ReadP' parser:+-- the expanded type is+-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @+readP_to_S (R f) = run (f return)++--readS_to_P :: ReadS a -> ReadP a+-- ^ Converts a Haskell ReadS-style function into a parser.+-- Warning: This introduces local backtracking in the resulting+-- parser, and therefore a possible inefficiency.+readS_to_P r =+ R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))++-- ---------------------------------------------------------------------------+-- QuickCheck properties that hold for the combinators++{- $properties+The following are QuickCheck specifications of what the combinators do.+These can be seen as formal specifications of the behavior of the+combinators.++We use bags to give semantics to the combinators.++> type Bag a = [a]++Equality on bags does not care about the order of elements.++> (=~) :: Ord a => Bag a -> Bag a -> Bool+> xs =~ ys = sort xs == sort ys++A special equality operator to avoid unresolved overloading+when testing the properties.++> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool+> (=~.) = (=~)++Here follow the properties:++> prop_Get_Nil =+> readP_to_S get [] =~ []+>+> prop_Get_Cons c s =+> readP_to_S get (c:s) =~ [(c,s)]+>+> prop_Look s =+> readP_to_S look s =~ [(s,s)]+>+> prop_Fail s =+> readP_to_S pfail s =~. []+>+> prop_Return x s =+> readP_to_S (return x) s =~. [(x,s)]+>+> prop_Bind p k s =+> readP_to_S (p >>= k) s =~.+> [ ys''+> | (x,s') <- readP_to_S p s+> , ys'' <- readP_to_S (k (x::Int)) s'+> ]+>+> prop_Plus p q s =+> readP_to_S (p +++ q) s =~.+> (readP_to_S p s ++ readP_to_S q s)+>+> prop_LeftPlus p q s =+> readP_to_S (p <++ q) s =~.+> (readP_to_S p s +<+ readP_to_S q s)+> where+> [] +<+ ys = ys+> xs +<+ _ = xs+>+> prop_Gather s =+> forAll readPWithoutReadS $ \p -> +> readP_to_S (gather p) s =~+> [ ((pre,x::Int),s')+> | (x,s') <- readP_to_S p s+> , let pre = take (length s - length s') s+> ]+>+> prop_String_Yes this s =+> readP_to_S (string this) (this ++ s) =~+> [(this,s)]+>+> prop_String_Maybe this s =+> readP_to_S (string this) s =~+> [(this, drop (length this) s) | this `isPrefixOf` s]+>+> prop_Munch p s =+> readP_to_S (munch p) s =~+> [(takeWhile p s, dropWhile p s)]+>+> prop_Munch1 p s =+> readP_to_S (munch1 p) s =~+> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)]+>+> prop_Choice ps s =+> readP_to_S (choice ps) s =~.+> readP_to_S (foldr (+++) pfail ps) s+>+> prop_ReadS r s =+> readP_to_S (readS_to_P r) s =~. r s+-}++#endif
+ Distribution/Compiler.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.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.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+-- ------------------------------------------------------------++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+-- ------------------------------------------------------------++#ifdef DEBUG+hunitTests :: [Test]+hunitTests = []+#endif
+ Distribution/Extension.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Extension+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Haskell language extensions++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Extension+{-# DEPRECATED "Use modules Language.Haskell.Extension and Distribution.Compiler instead" #-}+ (Extension(..), Opt,+ extensionsToNHCFlag, extensionsToGHCFlag,+ extensionsToJHCFlag, extensionsToHugsFlag+ ) where++import Distribution.Compiler (Opt, extensionsToNHCFlag, extensionsToGHCFlag,+ extensionsToJHCFlag, extensionsToHugsFlag)+import Language.Haskell.Extension (Extension(..))
+ Distribution/GetOpt.hs view
@@ -0,0 +1,326 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.GetOpt+-- Copyright : (c) Sven Panne 2002-2005+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- This library provides facilities for parsing the command-line options+-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library.+--+-----------------------------------------------------------------------------++{-+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+ are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+ compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example! +:-)+-}++-- #hide+module Distribution.GetOpt (+ -- * GetOpt+ getOpt, getOpt',+ usageInfo,+ ArgOrder(..),+ OptDescr(..),+ ArgDescr(..),++ -- * Example++ -- $example+) where++#if __GLASGOW_HASKELL__ >= 604 || !__GLASGOW_HASKELL__++import System.Console.GetOpt++#else+-- to end of file:++import Data.List ( isPrefixOf )++-- |What to do with options following non-options+data ArgOrder a+ = RequireOrder -- ^ no option processing after first non-option+ | Permute -- ^ freely intersperse options and non-options+ | ReturnInOrder (String -> a) -- ^ wrap non-options into options++{-|+Each 'OptDescr' describes a single option.++The arguments to 'Option' are:++* list of short option characters++* list of long option strings (without \"--\")++* argument descriptor++* explanation of option for user+-}+data OptDescr a = -- description of a single options:+ Option [Char] -- list of short option characters+ [String] -- list of long option strings (without "--")+ (ArgDescr a) -- argument descriptor+ String -- explanation of option for user++-- |Describes whether an option takes an argument or not, and if so+-- how the argument is injected into a value of type @a@.+data ArgDescr a+ = NoArg a -- ^ no argument expected+ | ReqArg (String -> a) String -- ^ option requires argument+ | OptArg (Maybe String -> a) String -- ^ optional argument++data OptKind a -- kind of cmd line arg (internal use only):+ = Opt a -- an option+ | UnreqOpt String -- an un-recognized option+ | NonOpt String -- a non-option+ | EndOfOpts -- end-of-options marker (i.e. "--")+ | OptErr String -- something went wrong...++-- | Return a string describing the usage of a command, derived from+-- the header (first argument) and the options described by the +-- second argument.+usageInfo :: String -- header+ -> [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 ]++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)++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg _ ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg _ ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++{-|+Process the command-line, and return the list of values that matched+(and those that didn\'t). The arguments are:++* The order requirements (see 'ArgOrder')++* The option descriptions (see 'OptDescr')++* The actual command line arguments (presumably got from + 'System.Environment.getArgs').++'getOpt' returns a triple consisting of the option arguments, a list+of non-options, and a list of error messages.+-}+getOpt :: ArgOrder a -- non-option handling+ -> [OptDescr a] -- option descriptors+ -> [String] -- the command-line arguments+ -> ([a],[String],[String]) -- (options,non-options,error messages)+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)+ where (os,xs,us,es) = getOpt' ordering optDescr args++{-|+This is almost the same as 'getOpt', but returns a quadruple+consisting of the option arguments, a list of non-options, a list of+unrecognized options, and a list of error messages.+-}+getOpt' :: ArgOrder a -- non-option handling+ -> [OptDescr a] -- option descriptors+ -> [String] -- the command-line arguments+ -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)+getOpt' _ _ [] = ([],[],[],[])+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering+ where procNextOpt (Opt o) _ = (o:os,xs,us,es)+ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])+ procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)+ procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])+ procNextOpt EndOfOpts Permute = ([],rest,[],[])+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])+ procNextOpt (OptErr e) _ = (os,xs,us,e:es)++ (opt,rest) = getNext arg args optDescr+ (os,xs,us,es) = getOpt' ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a rest _ = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+ where (opt,arg) = break (=='=') ls+ getWith p = [ o | o@(Option _ xs _ _) <- optDescr, x <- xs, opt `p` x ]+ exact = getWith (==)+ options = if null exact then getWith isPrefixOf else exact+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = ("--"++opt)++ long (_:_:_) _ rest = (errAmbig options optStr,rest)+ long [NoArg a ] [] rest = (Opt a,rest)+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)+ long [ReqArg _ d] [] [] = (errReq d optStr,[])+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)+ long _ _ rest = (UnreqOpt ("--"++ls),rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt y ys rs optDescr = short ads ys rs+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]+ ads = [ ad | Option _ _ ad _ <- options ]+ optStr = '-':[y]++ short (_:_:_) _ rest = (errAmbig options optStr,rest)+ short (NoArg a :_) [] rest = (Opt a,rest)+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)+ short [] [] rest = (UnreqOpt optStr,rest)+ short [] xs rest = (UnreqOpt optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+ where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> String+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show++options :: [OptDescr Flag]+options =+ [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",+ Option ['V','?'] ["version","release"] (NoArg Version) "show version info",+ Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",+ Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+ (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"+ (_,_,errs) -> concat errs ++ usageInfo header options+ where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+-- ==> options=[] args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+-- ==> options=[Verbose] args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+-- ==> options=[Arg "foo", Verbose] args=[]+-- putStr (test Permute ["foo","--","-v"])+-- ==> options=[] args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]+-- putStr (test Permute ["--ver","foo"])+-- ==> option `--ver' is ambiguous; could be one of:+-- -v --verbose verbosely list files+-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files...+-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files+-----------------------------------------------------------------------------------------+-}++#endif++{- $example++To hopefully illuminate the role of the different data+structures, here\'s the command-line options for a (very simple)+compiler:++> module Opts where+> +> import Distribution.GetOpt+> import Data.Maybe ( fromMaybe )+> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String+> deriving Show+> +> options :: [OptDescr Flag]+> options =+> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"+> , Option ['V','?'] ["version"] (NoArg Version) "show version number"+> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"+> , Option ['c'] [] (OptArg inp "FILE") "input FILE"+> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"+> ]+> +> inp,outp :: Maybe String -> Flag+> outp = Output . fromMaybe "stdout"+> inp = Input . fromMaybe "stdin"+> +> compilerOpts :: [String] -> IO ([Flag], [String])+> compilerOpts argv = +> case getOpt Permute options argv of+> (o,n,[] ) -> return (o,n)+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+> where header = "Usage: ic [OPTION...] files..."++-}
+ Distribution/InstalledPackageInfo.hs view
@@ -0,0 +1,287 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.InstalledPackageInfo+-- Copyright : (c) The University of Glasgow 2004+-- +-- Maintainer : libraries@haskell.org+-- Stability : alpha+-- Portability : portable+--+-- This is the information about an /installed/ package that+-- is communicated to the @hc-pkg@ program in order to register+-- a package. @ghc-pkg@ now consumes this package format (as of verison+-- 6.4). This is specific to GHC at the moment.+++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the University nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++-- This module is meant to be local-only to Distribution...++module Distribution.InstalledPackageInfo (+ InstalledPackageInfo(..),+ ParseResult(..),+ emptyInstalledPackageInfo,+ parseInstalledPackageInfo,+ showInstalledPackageInfo,+ showInstalledPackageInfoField,+ ) where++import Distribution.ParseUtils (+ StanzaField(..), singleStanza, ParseResult(..), LineNo,+ 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 )+import Distribution.Compat.ReadP as ReadP++import Control.Monad ( foldM )+import Text.PrettyPrint++-- -----------------------------------------------------------------------------+-- The InstalledPackageInfo type++data InstalledPackageInfo+ = InstalledPackageInfo {+ -- these parts are exactly the same as PackageDescription+ package :: PackageIdentifier,+ license :: License,+ copyright :: String,+ maintainer :: String,+ author :: String,+ stability :: String,+ homepage :: String,+ pkgUrl :: String,+ description :: String,+ category :: String,+ -- these parts are required by an installed package only:+ exposed :: Bool,+ exposedModules :: [String],+ hiddenModules :: [String],+ importDirs :: [FilePath], -- contain sources in case of Hugs+ libraryDirs :: [FilePath],+ hsLibraries :: [String],+ extraLibraries :: [String],+ extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi+ includeDirs :: [FilePath],+ includes :: [String],+ depends :: [PackageIdentifier],+ hugsOptions :: [Opt],+ ccOptions :: [Opt],+ ldOptions :: [Opt],+ frameworkDirs :: [FilePath],+ frameworks :: [String],+ haddockInterfaces :: [FilePath],+ haddockHTMLs :: [FilePath]+ }+ deriving (Read, Show)++emptyInstalledPackageInfo :: InstalledPackageInfo+emptyInstalledPackageInfo+ = InstalledPackageInfo {+ package = PackageIdentifier "" noVersion,+ license = AllRightsReserved,+ copyright = "",+ maintainer = "",+ author = "",+ stability = "",+ homepage = "",+ pkgUrl = "",+ description = "",+ category = "",+ exposed = False,+ exposedModules = [],+ hiddenModules = [],+ importDirs = [],+ libraryDirs = [],+ hsLibraries = [],+ extraLibraries = [],+ extraGHCiLibraries= [],+ includeDirs = [],+ includes = [],+ depends = [],+ hugsOptions = [],+ ccOptions = [],+ ldOptions = [],+ frameworkDirs = [],+ frameworks = [],+ haddockInterfaces = [],+ haddockHTMLs = []+ }++noVersion :: Version+noVersion = Version{ versionBranch=[], versionTags=[] }++-- -----------------------------------------------------------------------------+-- Parsing++parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo+parseInstalledPackageInfo inp = do+ stLines <- singleStanza inp+ -- not interested in stanzas, so just allow blank lines in+ -- the package info.+ foldM (parseBasicStanza fields) emptyInstalledPackageInfo stLines++parseBasicStanza :: [StanzaField a]+ -> a+ -> (LineNo, String, String)+ -> ParseResult a+parseBasicStanza ((StanzaField name _ set):fields) pkg (lineNo, f, val)+ | name == f = set lineNo val pkg+ | otherwise = parseBasicStanza fields pkg (lineNo, f, val)+parseBasicStanza [] pkg (_, _, _) = return pkg++-- -----------------------------------------------------------------------------+-- Pretty-printing++showInstalledPackageInfo :: InstalledPackageInfo -> String+showInstalledPackageInfo pkg = render (ppFields fields)+ where+ ppFields [] = empty+ ppFields ((StanzaField 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+ [] -> Nothing+ ((f,get'):_) -> Just (render . pprField f . get')++pprField name field = text name <> colon <+> field++-- -----------------------------------------------------------------------------+-- Description of the fields, for parsing/printing++fields :: [StanzaField InstalledPackageInfo]+fields = basicStanzaFields ++ installedStanzaFields++basicStanzaFields :: [StanzaField InstalledPackageInfo]+basicStanzaFields =+ [ simpleField "name"+ text parsePackageNameQ+ (pkgName . package) (\name pkg -> pkg{package=(package pkg){pkgName=name}})+ , simpleField "version"+ (text . showVersion) parseOptVersion + (pkgVersion . package) (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})+ , simpleField "license"+ (text . show) parseLicenseQ+ license (\l pkg -> pkg{license=l})+ , simpleField "copyright"+ showFreeText (munch (const True))+ copyright (\val pkg -> pkg{copyright=val})+ , simpleField "maintainer"+ showFreeText (munch (const True))+ maintainer (\val pkg -> pkg{maintainer=val})+ , 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 "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})+ ]++installedStanzaFields :: [StanzaField InstalledPackageInfo]+installedStanzaFields = [+ simpleField "exposed"+ (text.show) parseReadS+ exposed (\val pkg -> pkg{exposed=val})+ , listField "exposed-modules"+ text parseModuleNameQ+ exposedModules (\xs pkg -> pkg{exposedModules=xs})+ , listField "hidden-modules"+ text parseModuleNameQ+ hiddenModules (\xs pkg -> pkg{hiddenModules=xs})+ , listField "import-dirs"+ showFilePath parseFilePathQ+ importDirs (\xs pkg -> pkg{importDirs=xs})+ , listField "library-dirs"+ showFilePath parseFilePathQ+ libraryDirs (\xs pkg -> pkg{libraryDirs=xs})+ , listField "hs-libraries"+ showFilePath parseTokenQ+ hsLibraries (\xs pkg -> pkg{hsLibraries=xs})+ , listField "extra-libraries"+ showToken parseTokenQ+ extraLibraries (\xs pkg -> pkg{extraLibraries=xs})+ , listField "extra-ghci-libraries"+ showToken parseTokenQ+ extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs})+ , listField "include-dirs"+ showFilePath parseFilePathQ+ includeDirs (\xs pkg -> pkg{includeDirs=xs})+ , listField "includes"+ showFilePath parseFilePathQ+ includes (\xs pkg -> pkg{includes=xs})+ , listField "depends"+ (text.showPackageId) parsePackageId'+ depends (\xs pkg -> pkg{depends=xs})+ , listField "hugs-options"+ showToken parseTokenQ+ hugsOptions (\path pkg -> pkg{hugsOptions=path})+ , listField "cc-options"+ showToken parseTokenQ+ ccOptions (\path pkg -> pkg{ccOptions=path})+ , listField "ld-options"+ showToken parseTokenQ+ ldOptions (\path pkg -> pkg{ldOptions=path})+ , listField "framework-dirs"+ showFilePath parseFilePathQ+ frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs})+ , listField "frameworks"+ showToken parseTokenQ+ frameworks (\xs pkg -> pkg{frameworks=xs})+ , listField "haddock-interfaces"+ showFilePath parseFilePathQ+ haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs})+ , listField "haddock-html"+ showFilePath parseFilePathQ+ haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})+ ]++parsePackageId' = parseQuoted parsePackageId <++ parsePackageId
+ Distribution/License.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.License+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- The License datatype. For more information about these and other+-- open-source licenses, you may visit <http://www.opensource.org/>.+--+-- I am not a lawyer, but as a general guideline, most Haskell+-- software seems to be released under a BSD3 license, which is very+-- open and free. If you don't want to restrict the use of your+-- software or its source code, use BSD3 or PublicDomain.++{- 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.License (+ License(..)+ ) 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.++data License = GPL -- ^GNU Public License. Source code must accompany alterations.+ | LGPL -- ^Lesser GPL, Less restrictive than GPL, useful for libraries.+ | BSD3 -- ^3-clause BSD license, newer, no advertising clause. Very free license.+ | BSD4 -- ^4-clause BSD license, older, with advertising clause.+ | PublicDomain -- ^Holder makes no claim to ownership, least restrictive license.+ | AllRightsReserved -- ^No rights are granted to others. Undistributable. Most restrictive.+ | {- ... | -} OtherLicense -- ^Some other license.+ deriving (Read, Show, Eq)
+ Distribution/Make.hs view
@@ -0,0 +1,195 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Make+-- Copyright : Martin Sjögren 2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- 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.++{- 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.Make (+ module Distribution.Package,+ License(..), Version(..),+ defaultMain, defaultMainNoRead+ ) where++-- local+import Distribution.Package --must not specify imports, since we're exporting moule.+import Distribution.Program(defaultProgramConfiguration)+import Distribution.PackageDescription+import Distribution.Setup --(parseArgs, Action(..), optionHelpString)++import Distribution.Simple.Utils (die, maybeExit, defaultPackageDesc)++import Distribution.License (License(..))+import Distribution.Version (Version(..))++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++defaultMainNoRead :: PackageDescription -> IO ()+defaultMainNoRead pkg_descr+ = do args <- getArgs+ (action, args) <- parseGlobalArgs defaultProgramConfiguration args+ case action of+ ConfigCmd flags -> do+ (flags, _, args) <- parseConfigureArgs defaultProgramConfiguration flags args []+ retVal <- exec $ unwords $+ "./configure" : configureArgs flags ++ args+ 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+ let cmd = case copydest of + NoCopyDest -> "install"+ CopyTo path -> "copy destdir=" ++ path+ CopyPrefix path -> "install prefix=" ++ path+ -- CopyPrefix is backwards compat, DEPRECATED+ maybeExit $ system $ ("make " ++ cmd)++ InstallCmd -> do+ ((InstallFlags _ _), _, args) <- parseInstallArgs emptyInstallFlags args []+ no_extra_flags args+ maybeExit $ system $ "make install"+ retVal <- exec "make register"+ if (retVal == ExitSuccess)+ then putStrLn "Install Succeeded."+ else putStrLn "Install failed."+ exitWith retVal++ HaddockCmd -> do + (_, _, args) <- parseHaddockArgs emptyHaddockFlags args []+ no_extra_flags args+ retVal <- exec "make docs"+ case retVal of+ ExitSuccess -> do putStrLn "Haddock Succeeded"+ exitWith ExitSuccess+ _ -> do retVal' <- exec "make doc"+ case retVal' of+ ExitSuccess -> do putStrLn "Haddock Succeeded"+ exitWith ExitSuccess+ _ -> do putStrLn "Haddock Failed."+ exitWith retVal'++ BuildCmd -> basicCommand "Build" "make" (parseBuildArgs args [])++ CleanCmd -> basicCommand "Clean" "make clean" (parseCleanArgs args [])++ SDistCmd -> basicCommand "SDist" "make dist" (parseSDistArgs args [])++ RegisterCmd -> basicCommand "Register" "make register"+ (parseRegisterArgs emptyRegisterFlags args [])++ UnregisterCmd -> basicCommand "Unregister" "make unregister"+ (parseUnregisterArgs emptyRegisterFlags args [])+ ProgramaticaCmd -> basicCommand "Programatica" "make programatica"+ (parseProgramaticaArgs args [])++ HelpCmd -> exitWith ExitSuccess -- this is handled elsewhere++-- |convinience function for repetitions above+basicCommand :: String -- ^Command name+ -> String -- ^Command command+ -> (IO (b, [a], [String])) -- ^Command parser function+ -> IO ()+basicCommand commandName commandCommand commandParseFun = do + (_, _, args) <- commandParseFun+ no_extra_flags args+ retVal <- exec commandCommand+ putStrLn $ commandName ++ + if (retVal == ExitSuccess)+ then " Succeeded."+ else " Failed."+ exitWith retVal++no_extra_flags :: [String] -> IO ()+no_extra_flags [] = return ()+no_extra_flags extra_flags = + die $ "Unrecognised flags: " ++ concat (intersperse "," (extra_flags))
+ Distribution/Package.hs view
@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Package+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Packages.++{- 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.Package (+ PackageIdentifier(..),+ showPackageId, parsePackageId, parsePackageName,+ ) where++import Distribution.Version+import Distribution.Compat.ReadP as ReadP+import Data.Char ( isDigit, isAlphaNum )+import Data.List ( intersperse )++data PackageIdentifier+ = PackageIdentifier {+ pkgName :: String,+ pkgVersion :: Version+ }+ deriving (Read, Show, Eq, Ord)++showPackageId :: PackageIdentifier -> String+showPackageId (PackageIdentifier n (Version [] _)) = n -- if no version, don't show version.+showPackageId pkgid = + pkgName pkgid ++ '-': showVersion (pkgVersion pkgid)++parsePackageName :: ReadP r String+parsePackageName = do ns <- sepBy1 component (char '-')+ return (concat (intersperse "-" ns))+ where component = do + cs <- munch1 isAlphaNum+ if all isDigit cs then pfail else return cs+ -- each component must contain an alphabetic character, to avoid+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).++parsePackageId :: ReadP r PackageIdentifier+parsePackageId = do + n <- parsePackageName+ v <- (ReadP.char '-' >> parseVersion) <++ return (Version [] [])+ return PackageIdentifier{pkgName=n,pkgVersion=v}
+ Distribution/PackageDescription.hs view
@@ -0,0 +1,896 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.PackageDescription+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Package description and parsing.++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.PackageDescription (+ -- * Package descriptions+ PackageDescription(..),+ 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
+ Distribution/ParseUtils.hs view
@@ -0,0 +1,312 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.ParseUtils+-- Copyright : (c) The University of Glasgow 2004+-- +-- Maintainer : libraries@haskell.org+-- Stability : alpha+-- Portability : portable+--+-- Utilities for parsing PackageDescription and InstalledPackageInfo.+++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the University nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++-- This module is meant to be local-only to Distribution...++-- #hide+module Distribution.ParseUtils (+ LineNo, PError(..), PWarning,+ locatedErrorMsg, showError, syntaxError, warning,+ runP, ParseResult(..),+ StanzaField(..), splitStanzas, Stanza, singleStanza,+ parseFilePathQ, parseTokenQ,+ parseModuleNameQ, parseDependency, parseOptVersion,+ parsePackageNameQ, parseVersionRangeQ,+ parseTestedWithQ, parseLicenseQ, parseExtensionQ, parseCommaList, parseOptCommaList,+ showFilePath, showToken, showTestedWith, showDependency, showFreeText,+ simpleField, listField, commaListField, optsField, + parseReadS, 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)++-- -----------------------------------------------------------------------------++type LineNo = Int++data PError = AmbigousParse String LineNo+ | NoParse String LineNo+ | FromString String (Maybe LineNo)+ deriving Show++type PWarning = String++data ParseResult a = ParseFailed PError | ParseOk [PWarning] a+ deriving Show++instance Monad ParseResult where+ return x = ParseOk [] x+ ParseFailed err >>= _ = ParseFailed err+ ParseOk ws x >>= f = case f x of+ ParseFailed err -> ParseFailed err+ ParseOk ws' x' -> ParseOk (ws'++ws) x'+ fail s = ParseFailed (FromString s Nothing)++runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a+runP lineNo field 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)+ 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 (NoParse f n) = (Just n, "Parse of field '"++f++"' failed: ")+locatedErrorMsg (FromString s n) = (n, s)++syntaxError :: LineNo -> String -> ParseResult a+syntaxError n s = ParseFailed $ FromString s (Just n)++warning :: String -> ParseResult ()+warning s = ParseOk [s] ()++data StanzaField a + = StanzaField + { fieldName :: String+ , fieldGet :: a -> Doc+ , fieldSet :: LineNo -> String -> a -> ParseResult a+ }++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))++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))++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))++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))++type Stanza = [(LineNo,String,String)]++-- |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)++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++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 [] = []++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'++-- |parse a module name+parseModuleNameQ :: ReadP r String+parseModuleNameQ = parseQuoted modu <++ modu+ where modu = do + c <- satisfy isUpper+ cs <- munch (\x -> isAlphaNum x || x `elem` "_'.")+ return (c:cs)++parseFilePathQ :: ReadP r FilePath+parseFilePathQ = liftM platformPath parseTokenQ++parseReadS :: Read a => ReadP r a+parseReadS = readS_to_P reads++parseDependency :: ReadP r Dependency+parseDependency = do name <- parsePackageNameQ+ skipSpaces+ ver <- parseVersionRangeQ <++ return AnyVersion+ skipSpaces+ return $ Dependency name ver++parsePackageNameQ :: ReadP r String+parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName ++parseVersionRangeQ :: ReadP r VersionRange+parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange++parseOptVersion :: ReadP r Version+parseOptVersion = parseQuoted ver <++ ver+ where ver = parseVersion <++ return noVersion+ noVersion = Version{ versionBranch=[], versionTags=[] }++parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)+parseTestedWithQ = parseQuoted tw <++ tw+ where tw = do compiler <- parseReadS+ skipSpaces+ version <- parseVersionRange <++ return AnyVersion+ skipSpaces+ return (compiler,version)++parseLicenseQ :: ReadP r License+parseLicenseQ = parseQuoted parseReadS <++ parseReadS++-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a+-- because the "compat" version of ReadP isn't quite powerful enough. In+-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a+-- Hence the trick above to make 'lic' polymorphic.++parseExtensionQ :: ReadP r Extension+parseExtensionQ = parseQuoted parseReadS <++ parseReadS++parseTokenQ :: ReadP r String+parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')++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++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++parseQuoted :: ReadP r a -> ReadP r a+parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p++-- --------------------------------------------+-- ** Pretty printing++showFilePath :: FilePath -> Doc+showFilePath = showToken++showToken :: String -> Doc+showToken str+ | not (any dodgy str) &&+ not (null str) = text str+ | otherwise = text (show str)+ where dodgy c = isSpace c || c == ','++showTestedWith :: (CompilerFlavor,VersionRange) -> Doc+showTestedWith (compiler,version) = text (show compiler ++ " " ++ showVersionRange version)++showDependency :: Dependency -> Doc+showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)++-- | Pretty-print free-format text, ensuring that it is vertically aligned,+-- and with blank lines replaced by dots for correct re-parsing.+showFreeText :: String -> Doc+showFreeText s = vcat [text (if null l then "." else l) | l <- lines s]
+ Distribution/PreProcess.hs view
@@ -0,0 +1,308 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,280 @@+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
@@ -0,0 +1,808 @@+{-# 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?+-}+
+ Distribution/Simple.hs view
@@ -0,0 +1,692 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Simple build system; basically the interface for+-- Distribution.Simple.\* modules. When given the parsed command-line+-- args and package information, is able to perform basic commands+-- like configure, build, install, register, etc.+--+-- This module isn't called \"Simple\" because it's simple. Far from+-- it. It's called \"Simple\" because it does complicated things to+-- simple software.++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Simple (+ module Distribution.Package,+ module Distribution.Version,+ module Distribution.License,+ module Distribution.Compiler,+ module Language.Haskell.Extension,+ -- * Simple interface+ defaultMain, defaultMainNoRead, defaultMainArgs,+ -- * Customization+ UserHooks(..), Args,+ defaultMainWithHooks, defaultUserHooks, emptyUserHooks,+ defaultHookedPackageDesc+#ifdef DEBUG + ,simpleHunitTests+#endif+ ) where++-- local+import Distribution.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,+ preprocessSources, PPSuffixHandler)+import Distribution.Setup++import Distribution.Simple.Build ( build )+import Distribution.Simple.SrcDist ( sdist )+import Distribution.Simple.Register ( register, unregister,+ writeInstalledConfig, installedPkgConfigFile,+ regScriptLocation, unregScriptLocation+ )++import Distribution.Simple.Configure(getPersistBuildConfig, maybeGetPersistBuildConfig,+ findProgram, configure, writePersistBuildConfig,+ localBuildInfoFile)++import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Install(install)+import Distribution.Simple.Utils (die, currentDir, rawSystemVerbose,+ defaultPackageDesc, defaultHookedPackageDesc,+ moduleToFilePath, findFile,+ distPref, srcPref, haddockPref)++#if mingw32_HOST_OS || mingw32_TARGET_OS+import Distribution.Simple.Utils (rawSystemPath)+#endif+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 System.IO.Error (try)+import Distribution.GetOpt++import Distribution.Compat.Directory(createDirectoryIfMissing,removeDirectoryRecursive, copyFile)+import Distribution.Compat.FilePath(joinFileName, joinPaths, joinFileExt,+ splitFileName, splitFileExt, changeFileExt)++#ifdef DEBUG+import HUnit (Test)+import Distribution.Version hiding (hunitTests)+#else+import Distribution.Version+#endif++type Args = [String]++-- | WARNING: The hooks interface is under rather constant flux as we+-- try to understand users needs. Setup files that depend on this+-- interface may break in future releases. Hooks allow authors to add+-- specific functionality before and after a command is run, and also+-- to specify additional preprocessors.+data UserHooks = UserHooks+ {+ runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ExitCode, -- ^Used for @.\/setup test@+ readDesc :: IO (Maybe PackageDescription), -- ^Read the description file+ hookedPreProcessors :: [ PPSuffixHandler ],+ -- ^Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.+ hookedPrograms :: [Program],+ -- ^These programs are detected at configure time. Arguments for them are added to the configure command.++ -- |Hook to run before configure command+ preConf :: Args -> ConfigFlags -> IO HookedBuildInfo,+ -- |Over-ride this hook to get different behavior during configure.+ confHook :: PackageDescription -> ConfigFlags -> IO LocalBuildInfo,+ -- |Hook to run after configure command+ postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode,++ -- |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 (),+ -- |Hook to run after build command. Second arg indicates verbosity level.+ postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode,++ -- |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 (),+ -- |Hook to run after clean command. Second arg indicates verbosity level.+ postClean :: Args -> CleanFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO ExitCode,++ -- |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 (),+ -- |Hook to run after copy command+ postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode,++ -- |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 (),+ -- |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,++ -- |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 (),+ -- |Hook to run after sdist command. Second arg indicates verbosity level.+ postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO ExitCode,++ -- |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 (),+ -- |Hook to run after register command+ postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode,++ -- |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 (),+ -- |Hook to run after unregister command+ postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode,++ -- |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,++ -- |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 (),+ -- |Hook to run after pfe command. Second arg indicates verbosity level.+ postPFE :: Args -> PFEFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode++ }++-- |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++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 ()++-- | 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 ()++-- |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 ()++-- |Combine the programs in the given hooks with the programs built+-- into cabal.+allPrograms :: Maybe UserHooks+ -> ProgramConfiguration -- combine defaults w/ user programs+allPrograms Nothing = defaultProgramConfiguration+allPrograms (Just h) = foldl (\pConf p -> updateProgram (Just p) pConf)+ defaultProgramConfiguration+ (hookedPrograms h)++-- |Combine the preprocessors in the given hooks with the+-- preprocessors built into cabal.+allSuffixHandlers :: Maybe UserHooks+ -> [PPSuffixHandler]+allSuffixHandlers hooks+ = maybe knownSuffixHandlers+ (\h -> overridesPP (hookedPreProcessors h) knownSuffixHandlers)+ hooks+ where+ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]+ overridesPP = unionBy (\x y -> fst x == fst y)++-- |Helper function for /defaultMain/ and /defaultMainNoRead/+defaultMainWorker :: PackageDescription+ -> Action+ -> [String] -- ^args1+ -> Maybe UserHooks+ -> IO ExitCode+defaultMainWorker pkg_descr_in action args hooks+ = 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++ let c = maybe (confHook defaultUserHooks) confHook hooks+ localbuildinfo <- c pkg_descr flags+ writePersistBuildConfig (foldr id localbuildinfo optFns)+ postHook postConf args flags pkg_descr localbuildinfo++ BuildCmd -> do+ (flags, _, args) <- parseBuildArgs args []+ pkg_descr <- hookOrInArgs preBuild args flags+ localbuildinfo <- getPersistBuildConfig++ cmdHook buildHook pkg_descr localbuildinfo flags+ postHook postBuild args flags pkg_descr localbuildinfo++ HaddockCmd -> do+ (verbose, _, args) <- parseHaddockArgs emptyHaddockFlags args []+ pkg_descr <- hookOrInArgs preHaddock args verbose+ localbuildinfo <- getPersistBuildConfig++ cmdHook haddockHook pkg_descr localbuildinfo verbose+ postHook postHaddock args verbose pkg_descr localbuildinfo++ ProgramaticaCmd -> do+ (verbose, _, args) <- parseProgramaticaArgs args []+ pkg_descr <- hookOrInArgs prePFE args verbose+ localbuildinfo <- getPersistBuildConfig++ cmdHook pfeHook pkg_descr localbuildinfo verbose+ postHook postPFE args verbose pkg_descr localbuildinfo++ CleanCmd -> do+ (verbose,_, args) <- parseCleanArgs args []+ pkg_descr <- hookOrInArgs preClean args verbose+ maybeLocalbuildinfo <- maybeGetPersistBuildConfig++ cmdHook cleanHook pkg_descr maybeLocalbuildinfo verbose+ postHook postClean args verbose pkg_descr maybeLocalbuildinfo++ CopyCmd mprefix -> do+ (flags, _, args) <- parseCopyArgs (CopyFlags mprefix 0) args []+ pkg_descr <- hookOrInArgs preCopy args flags+ localbuildinfo <- getPersistBuildConfig++ cmdHook copyHook pkg_descr localbuildinfo flags+ postHook postCopy args flags pkg_descr localbuildinfo++ InstallCmd -> do+ (flags, _, args) <- parseInstallArgs emptyInstallFlags args []+ pkg_descr <- hookOrInArgs preInst args flags+ localbuildinfo <- getPersistBuildConfig++ cmdHook instHook pkg_descr localbuildinfo flags+ postHook postInst args flags pkg_descr localbuildinfo++ SDistCmd -> do+ (flags,_, args) <- parseSDistArgs args []+ pkg_descr <- hookOrInArgs preSDist args flags+ maybeLocalbuildinfo <- maybeGetPersistBuildConfig++ cmdHook sDistHook pkg_descr maybeLocalbuildinfo flags+ postHook postSDist args flags pkg_descr maybeLocalbuildinfo++ 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++ 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++ 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++ HelpCmd -> return ExitSuccess -- 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+++getModulePaths :: BuildInfo -> [String] -> IO [FilePath]+getModulePaths 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+ )++ 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)++pfe :: PackageDescription -> LocalBuildInfo -> Maybe UserHooks -> PFEFlags -> IO ()+pfe pkg_descr _lbi hooks (PFEFlags verbose) = do+ let pps = allSuffixHandlers hooks+ unless (hasLibs pkg_descr) $+ die "no libraries found in this project"+ withLib pkg_descr () $ \lib -> do+ lbi <- getPersistBuildConfig+ let bi = libBuildInfo lib+ let mods = exposedModules lib ++ otherModules (libBuildInfo lib)+ preprocessSources pkg_descr lbi verbose pps+ inFiles <- getModulePaths bi mods+ rawSystemProgramConf verbose (programName pfesetupProgram) (withPrograms lbi)+ ("noplogic":"cpp": (if verbose > 4 then ["-v"] else [])+ ++ inFiles)+ return ()++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)+ mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)++ when (isJust maybeLbi) $ do+ let lbi = fromJust maybeLbi+ try $ removeDirectoryRecursive (buildDir lbi)+ case compilerFlavor (compiler lbi) of+ GHC -> cleanGHCExtras lbi+ JHC -> cleanJHCExtras lbi+ _ -> return ()+ 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")+ removePreprocessedPackage pkg_descr currentDir ["ho"]+ removeFileOrDirectory :: FilePath -> IO ()+ removeFileOrDirectory fname = do+ isDir <- doesDirectoryExist fname+ isFile <- doesFileExist fname+ if isDir then removeDirectoryRecursive fname+ else if isFile then removeFile fname+ else return ()++no_extra_flags :: [String] -> IO ()+no_extra_flags [] = return ()+no_extra_flags extra_flags = + die ("Unrecognised flags: " ++ concat (intersperse "," 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 }++-- |Empty 'UserHooks' which do nothing.+emptyUserHooks :: UserHooks+emptyUserHooks+ = UserHooks+ {+ runTests = res,+ readDesc = return Nothing,+ hookedPreProcessors = [],+ hookedPrograms = [],+ preConf = rn,+ confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),+ postConf = res,+ preBuild = rn,+ buildHook = ru,+ postBuild = res,+ preClean = rn,+ cleanHook = ru,+ postClean = res,+ preCopy = rn,+ copyHook = ru,+ postCopy = res,+ preInst = rn,+ instHook = ru,+ postInst = res,+ preSDist = rn,+ sDistHook = ru,+ postSDist = res,+ preReg = rn,+ regHook = ru,+ postReg = res,+ preUnreg = rn,+ unregHook = ru,+ postUnreg = res,+ prePFE = rn,+ pfeHook = ru,+ postPFE = res,+ preHaddock = rn,+ haddockHook = ru,+ postHaddock = res+ }+ where rn _ _ = return emptyHookedBuildInfo+ res _ _ _ _ = return ExitSuccess+ ru _ _ _ _ = return ()++-- |Basic default 'UserHooks':+--+-- * on non-Windows systems, 'postConf' runs @.\/configure@, if present.+--+-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst',+-- 'preReg' and 'preUnreg' read additional build information from+-- /package/@.buildinfo@, if present.+--+-- Thus @configure@ can use local system information to generate+-- /package/@.buildinfo@ and possibly other files.++-- FIXME: do something sensible for windows, or do nothing in postConf.++defaultUserHooks :: UserHooks+defaultUserHooks+ = emptyUserHooks+ {+ postConf = defaultPostConf,+ confHook = configure,+ preBuild = readHook buildVerbose,+ buildHook = defaultBuildHook,+ 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,+ 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+ 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++ readHook :: (a -> Int) -> Args -> a -> IO HookedBuildInfo+ readHook verbose 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++defaultInstallHook :: PackageDescription -> LocalBuildInfo+ -> Maybe UserHooks ->InstallFlags -> IO ()+defaultInstallHook pkg_descr localbuildinfo _ (InstallFlags uInstFlag verbose) = do+ install pkg_descr localbuildinfo (CopyFlags NoCopyDest verbose)+ when (hasLibs pkg_descr) $+ register pkg_descr localbuildinfo + emptyRegisterFlags{ regUser=uInstFlag, regVerbose=verbose }++defaultBuildHook :: PackageDescription -> LocalBuildInfo+ -> Maybe 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++defaultRegHook :: PackageDescription -> LocalBuildInfo+ -> Maybe 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"++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------+#ifdef DEBUG+simpleHunitTests :: [Test]+simpleHunitTests = []+#endif
+ Distribution/Simple/Build.hs view
@@ -0,0 +1,282 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Build+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--++{- Copyright (c) 2003-2005, Isaac Jones+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.Build (+ build+#ifdef DEBUG + ,hunitTests+#endif+ ) where++import Distribution.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.LocalBuildInfo+ ( LocalBuildInfo(..), mkBinDir, mkBinDirRel,+ mkLibDir, mkLibDirRel, mkDataDir,mkDataDirRel,+ mkLibexecDir, mkLibexecDirRel )+import Distribution.Simple.Configure+ ( localBuildInfoFile )+import Distribution.Simple.Utils( die )++import Distribution.Compat.Directory+ ( createDirectoryIfMissing )+import Distribution.Compat.FilePath+ ( joinFileName, pathSeparator )++import Data.Maybe ( maybeToList, fromJust )+import Control.Monad ( unless )+import System.Directory ( getModificationTime, doesFileExist)++import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.JHC as JHC+-- import qualified Distribution.Simple.NHC as NHC+import qualified Distribution.Simple.Hugs as Hugs++#ifdef mingw32_HOST_OS+import Distribution.PackageDescription (hasLibs)+#endif++#ifdef DEBUG+import HUnit (Test)+#endif++-- -----------------------------------------------------------------------------+-- Build the library++build :: PackageDescription+ -> LocalBuildInfo+ -> BuildFlags+ -> [ PPSuffixHandler ]+ -> IO ()+build pkg_descr lbi (BuildFlags verbose) suffixes = do+ -- check that there's something to build+ let buildInfos =+ map libBuildInfo (maybeToList (library pkg_descr)) +++ map buildInfo (executables pkg_descr)+ unless (any buildable buildInfos) $ do+ let name = showPackageId (package pkg_descr)+ die ("Package " ++ name ++ " can't be built on this system.")++ createDirectoryIfMissing True (buildDir lbi)++ -- construct and write the Paths_<pkg>.hs file+ createDirectoryIfMissing 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.")++-- ------------------------------------------------------------+-- * Building Paths_<pkg>.hs+-- ------------------------------------------------------------++-- The directory in which we put auto-generated modules+autogenModulesDir :: LocalBuildInfo -> String+autogenModulesDir lbi = buildDir lbi `joinFileName` "autogen"++buildPathsModule :: PackageDescription -> LocalBuildInfo -> IO ()+buildPathsModule pkg_descr lbi =+ let pragmas+ | absolute = ""+ | otherwise =+ "{-# OPTIONS_GHC -fffi #-}\n"+++ "{-# LANGUAGE ForeignFunctionInterface #-}\n"++ foreign_imports+ | absolute = ""+ | otherwise =+ "import Foreign\n"+++ "import Foreign.C\n"+++ "import Data.Maybe\n"++ header =+ pragmas+++ "module " ++ paths_modulename ++ " (\n"+++ "\tversion,\n"+++ "\tgetBinDir, getLibDir, getDataDir, getLibexecDir,\n"+++ "\tgetDataFileName\n"+++ "\t) where\n"+++ "\n"+++ foreign_imports+++ "import Data.Version"+++ "\n"+++ "\nversion = " ++ show (pkgVersion (package pkg_descr))+++ "\n"++ body+ | absolute =+ "\nbindir = " ++ show flat_bindir +++ "\nlibdir = " ++ show flat_libdir +++ "\ndatadir = " ++ show flat_datadir +++ "\nlibexecdir = " ++ show flat_libexecdir +++ "\n"+++ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"+++ "getBinDir = return bindir\n"+++ "getLibDir = return libdir\n"+++ "getDataDir = return datadir\n"+++ "getLibexecDir = return libexecdir\n" +++ "\n"+++ "getDataFileName :: FilePath -> IO FilePath\n"+++ "getDataFileName name = return (datadir ++ "++path_sep++" ++ name)\n"+ | otherwise =+ "\nprefix = " ++ show (prefix lbi) +++ "\nbindirrel = " ++ show (fromJust flat_bindirrel) +++ "\n"+++ "\ngetBinDir :: IO FilePath\n"+++ "getBinDir = getPrefixDirRel bindirrel\n\n"+++ "getLibDir :: IO FilePath\n"+++ "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"+++ "getDataDir :: IO FilePath\n"+++ "getDataDir = "++mkGetDir flat_datadir flat_datadirrel++"\n\n"+++ "getLibexecDir :: IO FilePath\n"+++ "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"+++ "getDataFileName :: FilePath -> IO FilePath\n"+++ "getDataFileName name = do\n"+++ " dir <- getDataDir\n"+++ " return (dir `joinFileName` name)\n"+++ "\n"+++ get_prefix_stuff+ in do btime <- getModificationTime localBuildInfoFile+ exists <- doesFileExist paths_filepath+ ptime <- if exists+ then getModificationTime paths_filepath+ else return btime+ if btime >= ptime+ 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+ + mkGetDir dir (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++ paths_modulename = autogenModuleName pkg_descr+ paths_filename = paths_modulename ++ ".hs"+ paths_filepath = autogenModulesDir lbi `joinFileName` paths_filename++ path_sep = show [pathSeparator]++get_prefix_stuff :: String+get_prefix_stuff =+ "getPrefixDirRel :: FilePath -> IO FilePath\n"+++ "getPrefixDirRel dirRel = do \n"+++ " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"+++ " buf <- mallocArray len\n"+++ " ret <- getModuleFileName nullPtr buf len\n"+++ " if ret == 0 \n"+++ " then do free buf;\n"+++ " return (prefix `joinFileName` dirRel)\n"+++ " else do exePath <- peekCString buf\n"+++ " free buf\n"+++ " let (bindir,_) = splitFileName exePath\n"+++ " return (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"+++ "\n"+++ "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"+++ " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n"+++ "\n"+++ "joinFileName :: String -> String -> FilePath\n"+++ "joinFileName \"\" fname = fname\n"+++ "joinFileName \".\" fname = fname\n"+++ "joinFileName dir \"\" = dir\n"+++ "joinFileName dir fname\n"+++ " | isPathSeparator (last dir) = dir++fname\n"+++ " | otherwise = dir++pathSeparator:fname\n"+++ "\n"+++ "splitFileName p = (reverse (path2++drive), reverse fname)\n"+++ " where\n"+++ " (path,drive) = case p of\n"+++ " (c:':':p) -> (reverse p,[':',c])\n"+++ " _ -> (reverse p,\"\")\n"+++ " (fname,path1) = break isPathSeparator path\n"+++ " path2 = case path1 of\n"+++ " [] -> \".\"\n"+++ " [_] -> path1 -- don't remove the trailing slash if \n"+++ " -- there is only one character\n"+++ " (c:path) | isPathSeparator c -> path\n"+++ " _ -> path1\n"+++ "\n"+++ "pathSeparator :: Char\n"+++ "pathSeparator = '\\\\'\n"+++ "\n"+++ "isPathSeparator :: Char -> Bool\n"+++ "isPathSeparator ch =\n"+++ " ch == '/' || ch == '\\\\'\n"++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++#ifdef DEBUG+hunitTests :: [Test]+hunitTests = []+#endif
+ Distribution/Simple/Configure.hs view
@@ -0,0 +1,486 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Configure+-- Copyright : Isaac Jones 2003-2005+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Perform the \"@.\/setup configure@\" action.+-- Outputs the @.setup-config@ file.++{- 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.Configure (writePersistBuildConfig,+ getPersistBuildConfig,+ maybeGetPersistBuildConfig,+ configure,+ localBuildInfoFile,+ findProgram,+ getInstalledPackages,+ configDependency,+ configCompiler, configCompilerAux,+#ifdef DEBUG+ hunitTests+#endif+ )+ where++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604+#if __GLASGOW_HASKELL__ < 603+#include "config.h"+#else+#include "ghcconfig.h"+#endif+#endif++import Distribution.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)++import Data.List (intersperse, nub, maximumBy, isPrefixOf)+import Data.Char (isSpace)+import Data.Maybe(fromMaybe)+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)+import Prelude hiding (catch)++#ifdef mingw32_HOST_OS+import Distribution.PackageDescription (hasLibs)+#endif++#ifdef DEBUG+import HUnit+#endif++tryGetPersistBuildConfig :: IO (Either String LocalBuildInfo)+tryGetPersistBuildConfig = do+ e <- doesFileExist localBuildInfoFile+ let dieMsg = "error reading " ++ localBuildInfoFile ++ "; run \"setup configure\" command?\n"+ if (not e) then return $ Left dieMsg else do + str <- readFile localBuildInfoFile+ case reads str of+ [(bi,_)] -> return $ Right bi+ _ -> return $ Left dieMsg++getPersistBuildConfig :: IO LocalBuildInfo+getPersistBuildConfig = do+ lbi <- tryGetPersistBuildConfig+ either die return lbi++maybeGetPersistBuildConfig :: IO (Maybe LocalBuildInfo)+maybeGetPersistBuildConfig = do+ lbi <- tryGetPersistBuildConfig+ return $ either (const Nothing) Just lbi++writePersistBuildConfig :: LocalBuildInfo -> IO ()+writePersistBuildConfig lbi = do+ writeFile localBuildInfoFile (show lbi)++localBuildInfoFile :: FilePath+localBuildInfoFile = "./.setup-config"++-- -----------------------------------------------------------------------------+-- * Configuration+-- -----------------------------------------------------------------------------++configure :: PackageDescription -> ConfigFlags -> IO LocalBuildInfo+configure pkg_descr cfg+ = do+ setupMessage "Configuring" pkg_descr+ removeInstalledConfig+ let lib = library pkg_descr+ -- detect compiler+ comp@(Compiler f' ver p' pkg) <- configCompilerAux cfg++ -- 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)++ -- 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))++ foundPrograms <- lookupPrograms (configPrograms cfg)++ 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)++ let newConfig = foldr (\(_, p) c -> updateProgram p c) (configPrograms cfg) foundPrograms++ -- 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)+ JHC -> do+ ipkgs <- getInstalledPackagesJHC comp cfg+ mapM (configDependency ipkgs) (buildDepends pkg_descr)+ _ -> do+ return $ map setDepByVersion (buildDepends pkg_descr)++ 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")+ 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+ }++ -- FIXME: maybe this should only be printed when verbose?+ message $ "Using install prefix: " ++ pref++ 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++ mapM (\(s,p) -> reportProgram' s p) foundPrograms++ reportProgram "happy" happy+ reportProgram "alex" alex+ reportProgram "hsc2hs" hsc2hs+ reportProgram "c2hs" c2hs+ reportProgram "cpphs" cpphs+ reportProgram "greencard" greencard++ 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++-- |Converts build dependencies to a versioned dependency. only sets+-- version information for exact versioned dependencies.+setDepByVersion :: Dependency -> PackageIdentifier++-- if they specify the exact version, use that:+setDepByVersion (Dependency s (ThisVersion v)) = PackageIdentifier s v++-- otherwise, just set it to empty+setDepByVersion (Dependency s _) = PackageIdentifier s (Version [] [])+++-- |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++reportProgram :: String -> Maybe FilePath -> IO ()+reportProgram name Nothing = message ("No " ++ name ++ " found")+reportProgram name (Just p) = message ("Using " ++ name ++ ": " ++ p)++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")+++-- | 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++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"++getInstalledPackagesAux :: Compiler -> ConfigFlags -> IO [PackageIdentifier]+getInstalledPackagesAux comp cfg = getInstalledPackages comp (configUser cfg) (configVerbose cfg)++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"++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++-- -----------------------------------------------------------------------------+-- Determining the compiler details++configCompilerAux :: ConfigFlags -> IO Compiler+configCompilerAux cfg = configCompiler (configHcFlavor cfg)+ (configHcPath cfg)+ (configHcPkg 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)++ 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++message :: String -> IO ()+message s = putStrLn $ "configure: " ++ s++-- -----------------------------------------------------------------------------+-- Tests++#ifdef DEBUG++hunitTests :: [Test]+hunitTests = []+{- Too specific:+packageID = PackageIdentifier "Foo" (Version [1] [])+ = [TestCase $+ do let simonMarGHCLoc = "/usr/bin/ghc"+ simonMarGHC <- configure emptyPackageDescription {package=packageID}+ (Just GHC,+ Just simonMarGHCLoc,+ Nothing, Nothing)+ assertEqual "finding ghc, etc on simonMar's machine failed"+ (LocalBuildInfo "/usr" (Compiler GHC + (Version [6,2,2] []) simonMarGHCLoc + (simonMarGHCLoc ++ "-pkg")) [] [])+ simonMarGHC+ ]+-}+#endif
+ Distribution/Simple/GHC.hs view
@@ -0,0 +1,435 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.GHC+-- Copyright : Isaac Jones 2003-2006+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--++{- Copyright (c) 2003-2005, Isaac Jones+All rights reserved.++Redistribution and use in source and binary forms, with or without+modiication, 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.GHC (+ build, installLib, installExe+ ) where++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+ ( localPackageConfig,+ canReadLocalPackageConfig )+import Language.Haskell.Extension (Extension(..))++import Control.Monad ( unless, when )+import Data.List ( isSuffixOf, nub )+import System.Directory ( removeFile, renameFile,+ getDirectoryContents, doesFileExist )+import System.Exit (ExitCode(..))++#ifdef mingw32_HOST_OS+import Distribution.Compat.FilePath ( splitFileName )+#endif++#ifndef __NHC__+import Control.Exception (try)+#else+import IO (try)+#endif++-- -----------------------------------------------------------------------------+-- 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+ let pref = buildDir lbi+ let ghcPath = compilerPath (compiler lbi)+ ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)+ ifProfLib = when (withProfLib lbi)+ ifGHCiLib = when (withGHCiLib lbi)++ -- GHC versions prior to 6.4 didn't have the user package database,+ -- so we fake it. TODO: This can go away in due course.+ pkg_conf <- if versionBranch (compilerVersion (compiler lbi)) >= [6,4]+ then return []+ else do pkgConf <- GHC.localPackageConfig+ pkgConfReadable <- GHC.canReadLocalPackageConfig+ if pkgConfReadable + then return ["-package-conf", pkgConf]+ else return []+ + -- Build lib+ withLib pkg_descr () $ \lib -> do+ when (verbose > 3) (putStrLn "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+ -- put hi-boot files into place for mutually recurive modules+ smartCopySources verbose (hsSourceDirs libBi)+ libTargetDir (libModules pkg_descr) ["hi-boot"] False False+ let ghc_vers = compilerVersion (compiler lbi)+ packageId | versionBranch ghc_vers >= [6,4]+ = showPackageId (package pkg_descr)+ | otherwise = pkgName (package pkg_descr)+ -- Only use the version number with ghc-6.4 and later+ ghcArgs =+ pkg_conf+ ++ ["-package-name", packageId ]+ ++ (if splitObjs lbi then ["-split-objs"] else [])+ ++ constructGHCCmdLine lbi libBi libTargetDir verbose+ ++ (libModules pkg_descr)+ ghcArgsProf = ghcArgs+ ++ ["-prof",+ "-hisuf", "p_hi",+ "-osuf", "p_o"+ ]+ ++ ghcProfOptions libBi+ unless (null (libModules pkg_descr)) $+ do ifVanillaLib forceVanillaLib (rawSystemExit verbose ghcPath ghcArgs)+ ifProfLib (rawSystemExit verbose ghcPath 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]++ -- link:+ when (verbose > 3) (putStrLn "cabal-linking...")+ let cObjs = [ path `joinFileName` file `joinFileExt` objExtension+ | (path, file, _) <- (map splitFilePath (cSources libBi)) ]+ libName = mkLibName pref (showPackageId (package pkg_descr))+ profLibName = mkProfLibName pref (showPackageId (package pkg_descr))+ ghciLibName = mkGHCiLibName pref (showPackageId (package pkg_descr))++ stubObjs <- sequence [moduleToFilePath [libTargetDir] (x ++"_stub") [objExtension]+ | x <- libModules pkg_descr ] >>= return . concat+ stubProfObjs <- sequence [moduleToFilePath [libTargetDir] (x ++"_stub") ["p_" ++ objExtension]+ | x <- libModules pkg_descr ] >>= return . concat++ hObjs <- getHaskellObjects pkg_descr libBi lbi+ pref objExtension+ hProfObjs <- + if (withProfLib lbi)+ then getHaskellObjects pkg_descr libBi lbi+ pref ("p_" ++ objExtension)+ 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 "")]+ ++ [libName]+ arObjArgs =+ hObjs+ ++ map (pref `joinFileName`) cObjs+ ++ stubObjs+ arProfArgs = ["q"++ (if verbose > 4 then "v" else "")]+ ++ [profLibName]+ arProfObjArgs =+ hProfObjs+ ++ map (pref `joinFileName`) cObjs+ ++ stubProfObjs+ ldArgs = ["-r"]+ ++ ["-x"] -- FIXME: only some systems's ld support the "-x" flag+ ++ ["-o", ghciLibName `joinFileExt` "tmp"]+ ldObjArgs =+ hObjs+ ++ map (pref `joinFileName`) 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+ --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++ ifProfLib $ maybeExit $ xargs maxCommandLineSize+ (rawSystemPath verbose) "ar" arProfArgs arProfObjArgs++ ifGHCiLib $ maybeExit $ xargs maxCommandLineSize+ runLd ld ldArgs ldObjArgs++ -- build any executables+ withExe pkg_descr $ \ (Executable exeName' modPath exeBi) -> do+ when (verbose > 3)+ (putStrLn $ "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 targetDir = pref `joinFileName` exeName'+ let exeDir = joinPaths targetDir (exeName' ++ "-tmp")+ createDirectoryIfMissing True targetDir+ createDirectoryIfMissing True exeDir+ -- put hi-boot files into place for mutually recursive modules+ -- FIX: what about exeName.hi-boot?+ smartCopySources verbose (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++ let cObjs = [ path `joinFileName` file `joinFileExt` objExtension+ | (path, file, _) <- (map splitFilePath (cSources exeBi)) ]+ let binArgs linkExe profExe =+ pkg_conf+ ++ ["-I"++pref]+ ++ (if linkExe+ then ["-o", targetDir `joinFileName` exeNameReal]+ else ["-c"])+ ++ constructGHCCmdLine lbi exeBi exeDir verbose+ ++ [exeDir `joinFileName` x | x <- cObjs]+ ++ [srcMainFile]+ ++ ldOptions exeBi+ ++ ["-l"++lib | lib <- extraLibs exeBi]+ ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]+ ++ if profExe+ then "-prof":ghcProfOptions exeBi+ else []++ -- For building exe's for profiling that use TH we actually+ -- have to build twice, once without profiling and the again+ -- with profiling. This is because the code that TH needs to+ -- run at compile time needs to be the vanilla ABI so it can+ -- be loaded up and run by the compiler.+ when (withProfExe lbi && TemplateHaskell `elem` extensions exeBi)+ (rawSystemExit verbose ghcPath (binArgs False False))++ rawSystemExit verbose ghcPath (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+ | splitObjs lbi = do+ let dirs = [ pref `joinFileName` (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 ]+ return objs+ | otherwise = + return [ pref `joinFileName` (dotToSep x) `joinFileExt` wanted_obj_ext+ | x <- libModules pkg_descr ]+++constructGHCCmdLine+ :: LocalBuildInfo+ -> BuildInfo+ -> FilePath+ -> Int -- verbosity level+ -> [String]+constructGHCCmdLine lbi bi odir verbose = + ["--make"]+ ++ (if verbose > 4 then ["-v"] else [])+ -- Unsupported extensions have already been checked by configure+ ++ (if compilerVersion (compiler lbi) > Version [6,4] []+ then ["-hide-all-packages"]+ else [])+ ++ ["-i"]+ ++ ["-i" ++ autogenModulesDir lbi]+ ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]+ ++ ["-I" ++ dir | dir <- includeDirs bi]+ ++ ["-optc" ++ opt | opt <- ccOptions bi]+ ++ [ "-#include \"" ++ inc ++ "\"" | inc <- includes bi ++ installIncludes bi ]+ ++ [ "-odir", odir, "-hidir", odir ]+ ++ (concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ])+ ++ hcOptions GHC (options bi)+ ++ snd (extensionsToGHCFlag (extensions bi))++mkGHCiLibName :: FilePath -- ^file Prefix+ -> String -- ^library name.+ -> String+mkGHCiLibName pref lib = pref `joinFileName` ("HS" ++ lib ++ ".o")++-- -----------------------------------------------------------------------------+-- 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)++-- |Install for ghc, .hi, .a and, if --with-ghci given, .o+installLib :: Int -- ^verbose+ -> ProgramConfiguration+ -> 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,+ package=p}+ = do ifVanilla $ smartCopySources verbose [buildPref] pref (libModules pd) ["hi"] True False+ ifProf $ smartCopySources verbose [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++ -- 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]++ 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+ 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/GHCPackageConfig.hs view
@@ -0,0 +1,165 @@+{-# 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/Hugs.hs view
@@ -0,0 +1,355 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Hugs+-- Copyright : Isaac Jones 2003-2006+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--++{- Copyright (c) 2003-2005, Isaac Jones+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.Hugs (+ build, install,+ hugsPackageDir+ ) where++import Distribution.PackageDescription+ ( PackageDescription(..), BuildInfo(..),+ 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+ ( unlit )+import Distribution.Simple.LocalBuildInfo+ ( LocalBuildInfo(..), + mkLibDir, autogenModulesDir )+import Distribution.Simple.Utils( rawSystemExit, die,+ dirOf, dotToSep, moduleToFilePath,+ smartCopySources, findFile )+import Language.Haskell.Extension+ ( Extension(..) )+import Distribution.Compat.Directory+ ( copyFile,createDirectoryIfMissing,+ removeDirectoryRecursive )+import Distribution.Compat.FilePath+ ( joinFileName, splitFileExt, joinFileExt,+ dllExtension, searchPathSeparator,+ platformPath )+++import Data.Char ( isSpace )+import Data.Maybe ( mapMaybe )+import Control.Monad ( unless, when, filterM )+#ifndef __NHC__+import Control.Exception ( try )+#else+import IO ( try )+#endif+import Data.List ( nub, sort, isSuffixOf )+import System.Directory ( Permissions(..), getPermissions,+ setPermissions )++-- -----------------------------------------------------------------------------++-- |Building a package for Hugs.+build :: PackageDescription -> LocalBuildInfo -> Int -> IO ()+build pkg_descr lbi verbose = do+ let pref = buildDir lbi+ withLib pkg_descr () $ \ l -> do+ copyFile (autogenModulesDir lbi `joinFileName` paths_modulename)+ (pref `joinFileName` paths_modulename)+ compileBuildInfo pref [] (libModules pkg_descr) (libBuildInfo l)+ withExe pkg_descr $ compileExecutable (pref `joinFileName` "programs")+ where+ 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+ copyModule (CPP `elem` extensions bi) bi srcMainFile destMainFile+ let destPathsFile = exeDir `joinFileName` paths_modulename+ copyFile (autogenModulesDir lbi `joinFileName` paths_modulename)+ destPathsFile+ compileBuildInfo exeDir (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi+ compileFiles bi exeDir [destMainFile, destPathsFile]+ + compileBuildInfo :: FilePath+ -> [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+ let useCpp = CPP `elem` extensions bi+ let srcDirs = nub $ hsSourceDirs bi ++ mLibSrcDirs+ when (verbose > 3) (putStrLn $ "Source directories: " ++ show srcDirs)+ flip mapM_ mods $ \ m -> do+ fs <- moduleToFilePath srcDirs m suffixes+ if null fs then+ die ("can't find source for module " ++ m)+ else do+ let srcFile = head fs+ let (_, ext) = splitFileExt srcFile+ copyModule useCpp bi srcFile+ (destDir `joinFileName` dotToSep m `joinFileExt` ext)+ -- Pass 2: compile foreign stubs in build directory+ stubsFileLists <- sequence [moduleToFilePath [destDir] modu suffixes |+ modu <- mods]+ compileFiles bi destDir (concat stubsFileLists)++ suffixes = ["hs", "lhs"]++ -- Copy or cpp a file from the source directory to the build directory.+ copyModule :: Bool -> BuildInfo -> FilePath -> FilePath -> IO ()+ copyModule cppAll bi srcFile destFile = do+ createDirectoryIfMissing True (dirOf 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+ return ()+ else+ copyFile srcFile destFile++ compileFiles :: BuildInfo -> FilePath -> [FilePath] -> IO ()+ 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++ -- Only compile FFI stubs for a file if it contains some FFI stuff+ testFFI :: FilePath -> IO Bool+ testFFI file = do+ inp <- readHaskellFile file+ return ("foreign" `elem` symbols (stripComments False inp))++ compileFFI :: BuildInfo -> FilePath -> FilePath -> IO ()+ 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 incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs))+ let pathFlag = "-P" ++ modDir ++ [searchPathSeparator]+ let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs+ cfiles <- getCFiles file+ let cArgs =+ ["-I" ++ dir | dir <- includeDirs bi] +++ ccOptions bi +++ cfiles +++ ["-L" ++ dir | dir <- extraLibDirs bi] +++ ldOptions bi +++ ["-l" ++ lib | lib <- extraLibs bi] +++ concat [["-framework", f] | f <- frameworks bi]+ rawSystemExit verbose ffihugs (hugsArgs ++ file : cArgs)++ ffihugs = compilerPath (compiler lbi)++ includeOpts :: [String] -> [String]+ includeOpts [] = []+ includeOpts ("-#include" : arg : opts) = arg : includeOpts opts+ includeOpts (_ : opts) = includeOpts opts++ -- get C file names from CFILES pragmas throughout the source file+ getCFiles :: FilePath -> IO [String]+ getCFiles file = do+ inp <- readHaskellFile file+ return [platformPath cfile |+ "{-#" : "CFILES" : rest <-+ map words $ lines $ stripComments True inp,+ last rest == "#-}",+ cfile <- init rest]++ -- List of terminal symbols in a source file.+ symbols :: String -> [String]+ symbols cs = case lex cs of+ (sym, cs'):_ | not (null sym) -> sym : symbols cs'+ _ -> []++ -- Get the non-literate source of a Haskell module.+ readHaskellFile :: FilePath -> IO String+ readHaskellFile file = do+ text <- readFile file+ return $ if ".lhs" `isSuffixOf` file then unlit file text else text++-- ------------------------------------------------------------+-- * options in source files+-- ------------------------------------------------------------++-- |Read the initial part of a source file, before any Haskell code,+-- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas.+getOptionsFromSource+ :: FilePath+ -> IO ([Extension], -- LANGUAGE pragma, if any+ [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas+ [String] -- INCLUDE pragmas+ )+getOptionsFromSource file = do+ text <- readFile file+ return $ foldr appendOptions ([],[],[]) $ map getOptions $+ takeWhileJust $ map getPragma $+ filter textLine $ map (dropWhile isSpace) $ lines $+ stripComments True $+ if ".lhs" `isSuffixOf` file then unlit file text else text+ where textLine [] = False+ textLine ('#':_) = False+ textLine _ = True++ getPragma :: String -> Maybe [String]+ getPragma line = case words line of+ ("{-#" : rest) | last rest == "#-}" -> Just (init rest)+ _ -> Nothing++ getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], [])+ getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], [])+ getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], [])+ getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], [])+ getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], [])+ where readExtension :: String -> Maybe Extension+ readExtension w = case reads w of+ [(ext, "")] -> Just ext+ [(ext, ",")] -> Just ext+ _ -> Nothing+ getOptions ("INCLUDE":ws) = ([], [], ws)+ getOptions _ = ([], [], [])++ appendOptions (exts, opts, incs) (exts', opts', incs')+ = (exts++exts', opts++opts', incs++incs')++-- takeWhileJust f = map fromJust . takeWhile isJust+takeWhileJust :: [Maybe a] -> [a]+takeWhileJust (Just x:xs) = x : takeWhileJust xs+takeWhileJust _ = []++-- |Strip comments from Haskell source.+stripComments+ :: Bool -- ^ preserve pragmas?+ -> String -- ^ input source text+ -> String+stripComments keepPragmas = stripCommentsLevel 0+ where stripCommentsLevel :: Int -> String -> String+ stripCommentsLevel 0 ('"':cs) = '"':copyString cs+ stripCommentsLevel 0 ('-':'-':cs) = -- FIX: symbols like -->+ stripCommentsLevel 0 (dropWhile (/= '\n') cs)+ stripCommentsLevel 0 ('{':'-':'#':cs)+ | keepPragmas = '{' : '-' : '#' : copyPragma cs+ stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs+ stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs+ stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs+ stripCommentsLevel n (c:cs) = stripCommentsLevel n cs+ stripCommentsLevel _ [] = []++ copyString ('\\':c:cs) = '\\' : c : copyString cs+ copyString ('"':cs) = '"' : stripCommentsLevel 0 cs+ copyString (c:cs) = c : copyString cs+ copyString [] = []++ copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs+ copyPragma (c:cs) = c : copyPragma cs+ copyPragma [] = []++-- -----------------------------------------------------------------------------+-- 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>+install+ :: Int -- ^verbose+ -> 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"+ when (any (buildable . buildInfo) (executables pkg_descr)) $+ createDirectoryIfMissing 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+ try $ removeDirectoryRecursive installDir+ smartCopySources verbose [buildDir] installDir+ ("Main" : autogenModuleName pkg_descr : otherModules (buildInfo exe)) hugsInstallSuffixes True False+ let targetName = "\"" ++ (targetDir `joinFileName` 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+ 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)++-- |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)
+ Distribution/Simple/Install.hs view
@@ -0,0 +1,133 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Install+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Perform the \"@.\/setup install@\" action. Move files into+-- place based on the prefix argument.++{- 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.Install (+ install,+#ifdef DEBUG + hunitTests+#endif+ ) where++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604+#if __GLASGOW_HASKELL__ < 603+#include "config.h"+#else+#include "ghcconfig.h"+#endif+#endif++import Distribution.PackageDescription (+ PackageDescription(..),+ setupMessage, hasLibs, withLib, 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)++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)++#ifdef DEBUG+import HUnit (Test)+#endif++-- |FIX: nhc isn't implemented yet.+install :: PackageDescription+ -> LocalBuildInfo+ -> CopyFlags+ -> 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+ let buildPref = buildDir lbi+ let libPref = mkLibDir pkg_descr lbi copydest+ let binPref = mkBinDir pkg_descr lbi copydest+ setupMessage ("Installing: " ++ libPref ++ " & " ++ binPref) pkg_descr+ case compilerFlavor (compiler lbi) of+ GHC -> do when (hasLibs pkg_descr)+ (GHC.installLib verbose (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+ 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+ _ -> die ("only installing with GHC, JHC or Hugs is implemented")+ return ()+ -- register step should be performed by caller.++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------+#ifdef DEBUG+hunitTests :: [Test]+hunitTests = []+#endif
+ Distribution/Simple/JHC.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.JHC+-- Copyright : Isaac Jones 2003-2006+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--++{- Copyright (c) 2003-2005, Isaac Jones+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.JHC (+ build, installLib, installExe+ ) where++import Distribution.PackageDescription+ ( PackageDescription(..), BuildInfo(..),+ withLib,+ Executable(..), withExe, Library(..),+ libModules, hcOptions )+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 Control.Monad ( when )+import Data.List ( nub, intersperse )+++-- -----------------------------------------------------------------------------+-- 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)+ withLib pkg_descr () $ \lib -> do+ when (verbose > 3) (putStrLn "Building library...")+ let libBi = libBuildInfo lib+ let args = constructJHCCmdLine lbi libBi (buildDir lbi) verbose+ rawSystemExit verbose jhcPath (["-c"] ++ args ++ libModules pkg_descr)+ let pkgid = showPackageId (package pkg_descr)+ pfile = buildDir lbi `joinFileName` "jhc-pkg.conf"+ hlfile= buildDir lbi `joinFileName` (pkgid ++ ".hl")+ writeFile pfile $ jhcPkgConf pkg_descr+ rawSystemExit verbose jhcPath ["--build-hl="++pfile, "-o", hlfile]+ withExe pkg_descr $ \exe -> do+ when (verbose > 3) (putStrLn ("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])++constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> FilePath -> Int -> [String]+constructJHCCmdLine lbi bi odir verbose =+ (if verbose > 4 then ["-v"] else [])+ ++ snd (extensionsToJHCFlag (extensions bi))+ ++ hcOptions JHC (options bi)+ ++ ["--noauto","-i-"]+ ++ ["-i", autogenModulesDir lbi]+ ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)]+ ++ ["-optc" ++ opt | opt <- ccOptions bi]+ ++ (concat [ ["-p", showPackageId pkg] | pkg <- packageDeps lbi ])++jhcPkgConf :: PackageDescription -> String+jhcPkgConf pd =+ let sline name sel = name ++ ": "++sel pd+ Just lib = library pd+ comma f l = concat $ intersperse "," $ map f l+ in unlines [sline "name" (showPackageId . package)+ ,"exposed-modules: " ++ (comma id (exposedModules lib))+ ,"hidden-modules: " ++ (comma id (otherModules $ libBuildInfo lib))+ ]+ +installLib :: Int -> FilePath -> FilePath -> PackageDescription -> Library -> IO ()+installLib verb dest build pkg_descr _ = do+ let p = showPackageId (package pkg_descr)++".hl"+ createDirectoryIfMissing True dest+ copyFileVerbose verb (joinFileName build p) (joinFileName 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)
+ Distribution/Simple/LocalBuildInfo.hs view
@@ -0,0 +1,324 @@+{-# OPTIONS -cpp -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.LocalBuildInfo+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Definition of the LocalBuildInfo data type.++{- 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.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+ ) where+++import Distribution.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++-- |Data cached after configuration step.+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+ compiler :: Compiler,+ -- ^ The compiler we're building with+ buildDir :: FilePath,+ -- ^ Where to put the result of building.+ packageDeps :: [PackageIdentifier],+ -- ^ Which packages we depend on, /exactly/.+ -- The 'Distribution.PackageDescription.PackageDescription'+ -- specifies a set of build dependencies+ -- that must be satisfied in terms of version ranges. This+ -- field fixes those dependencies to the specific versions+ -- available on this machine for this compiler.+ 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.+ withVanillaLib:: Bool, -- ^Whether to build normal libs.+ withProfLib :: Bool, -- ^Whether to build profiling versions of libs.+ withProfExe :: Bool, -- ^Whether to build executables for profiling.+ withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi.+ splitObjs :: Bool -- ^Use -split-objs with GHC, if available+ } deriving (Read, Show)++-- ------------------------------------------------------------+-- * Some Paths+-- ------------------------------------------------------------++distPref :: FilePath+distPref = "dist"++srcPref :: FilePath+srcPref = distPref `joinFileName` "src"++-- |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")++-- -----------------------------------------------------------------------------+-- 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"++default_libexecdir :: FilePath+default_libexecdir = "$prefix" `joinFileName`+#if mingw32_HOST_OS || mingw32_TARGET_OS+ "$pkgid"+#else+ "libexec"+#endif++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++default_datasubdir :: FilePath+default_datasubdir = "$pkgid"++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)++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)++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)++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
+ Distribution/Simple/NHC.hs view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.NHC+-- Copyright : Isaac Jones 2003-2006+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--++{- Copyright (c) 2003-2005, Isaac Jones+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.NHC (+ 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 )++-- |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+ -- Unsupported extensions have already been checked by configure+ let flags = snd $ extensionsToNHCFlag (maybe [] (extensions . libBuildInfo) (library pkg_descr))+ rawSystemExit verbose (compilerPath (compiler lbi))+ (["-nhc98"]+ ++ flags+ ++ maybe [] (hcOptions NHC . options . libBuildInfo) (library pkg_descr)+ ++ (libModules pkg_descr))+
+ Distribution/Simple/Register.hs view
@@ -0,0 +1,379 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Register+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Perform the \"@.\/setup register@\" action.+-- Uses a drop-file for HC-PKG. See also "Distribution.InstalledPackageInfo".++{- Copyright (c) 2003-2004, Isaac Jones+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.Register (+ register,+ unregister,+ writeInstalledConfig,+ removeInstalledConfig,+ installedPkgConfigFile,+ regScriptLocation,+ unregScriptLocation,+#ifdef DEBUG+ hunitTests+#endif+ ) where++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604+#if __GLASGOW_HASKELL__ < 603+#include "config.h"+#else+#include "ghcconfig.h"+#endif+#endif++import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), mkLibDir, mkHaddockDir,+ mkIncludeDir)+import Distribution.Compiler (CompilerFlavor(..), Compiler(..))+import Distribution.Setup (RegisterFlags(..), CopyDest(..), userOverride)+import Distribution.PackageDescription (setupMessage, PackageDescription(..),+ BuildInfo(..), Library(..), haddockName)+import Distribution.Package (PackageIdentifier(..), showPackageId)+import Distribution.Version (Version(..))+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+ as GHC (localPackageConfig, canWriteLocalPackageConfig, maybeCreateLocalPackageConfig)+import Distribution.Compat.Directory+ (createDirectoryIfMissing,removeDirectoryRecursive,+ setPermissions, getPermissions, Permissions(executable)+ )++import Distribution.Compat.FilePath (joinFileName, joinPaths, splitFileName,+ isAbsolutePath)++import System.Directory(doesFileExist, removeFile, getCurrentDirectory)+import System.IO.Error (try)++import Control.Monad (when, unless)+import Data.Maybe (isNothing, fromJust)+import Data.List (partition)++#ifdef DEBUG+import HUnit (Test)+#endif++regScriptLocation :: FilePath+#if mingw32_HOST_OS || mingw32_TARGET_OS+regScriptLocation = "register.bat"+#else+regScriptLocation = "register.sh"+#endif++unregScriptLocation :: FilePath+#if mingw32_HOST_OS || mingw32_TARGET_OS+unregScriptLocation = "unregister.bat"+#else+unregScriptLocation = "unregister.sh"+#endif++-- -----------------------------------------------------------------------------+-- Registration++register :: PackageDescription -> LocalBuildInfo+ -> RegisterFlags -- ^Install in the user's database?; verbose+ -> IO ()+register pkg_descr lbi regFlags+ | isNothing (library pkg_descr) = do+ setupMessage "No package to register" pkg_descr+ return ()+ | otherwise = do+ let ghc_63_plus = compilerVersion (compiler lbi) >= Version [6,3] []+ genScript = regGenScript regFlags+ verbose = regVerbose regFlags+ user = regUser regFlags `userOverride` userConf lbi+ inplace = regInPlace regFlags+ setupMessage (if genScript+ then ("Writing registration script: " ++ regScriptLocation)+ else "Registering")+ 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 []++ let instConf = if inplace then inplacePkgConfigFile + else installedPkgConfigFile++ instConfExists <- doesFileExist instConf+ when (not instConfExists && not genScript) $ do+ when (verbose > 0) $+ putStrLn ("create " ++ instConf)+ writeInstalledConfig pkg_descr lbi inplace++ 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)++ if genScript+ then do cfg <- showInstalledConfig pkg_descr lbi inplace+ rawSystemPipe regScriptLocation verbose cfg+ pkgTool allFlags+ else rawSystemExit verbose 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")++userPkgConfErr :: String -> IO a+userPkgConfErr local_conf = + die ("--user flag passed, but cannot write to local package config: "+ ++ local_conf )++-- -----------------------------------------------------------------------------+-- The installed package config++-- |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+ pkg_config <- showInstalledConfig pkg_descr lbi inplace+ writeFile (if inplace then inplacePkgConfigFile else installedPkgConfigFile)+ (pkg_config ++ "\n")++-- |Create a string suitable for writing out to the package config file+showInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool+ -> IO String+showInstalledConfig pkg_descr lbi inplace+ | (case compilerFlavor hc of GHC -> True; _ -> False) &&+ compilerVersion hc < Version [6,3] [] + = if inplace then+ error "--inplace not supported for GHC < 6.3"+ else+ return (showGHCPackageConfig (mkGHCPackageConfig pkg_descr lbi))+ | otherwise + = do cfg <- mkInstalledPackageInfo pkg_descr lbi inplace+ return (showInstalledPackageInfo cfg)+ where+ hc = compiler lbi++removeInstalledConfig :: IO ()+removeInstalledConfig = do+ try (removeFile installedPkgConfigFile) >> return ()+ try (removeFile inplacePkgConfigFile) >> return ()++installedPkgConfigFile :: String+installedPkgConfigFile = ".installed-pkg-config"++inplacePkgConfigFile :: String+inplacePkgConfigFile = ".inplace-pkg-config"++-- -----------------------------------------------------------------------------+-- Making the InstalledPackageInfo++mkInstalledPackageInfo+ :: PackageDescription+ -> LocalBuildInfo+ -> Bool+ -> IO InstalledPackageInfo+mkInstalledPackageInfo pkg_descr lbi inplace = do + pwd <- getCurrentDirectory+ 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)+ in+ return emptyInstalledPackageInfo{+ IPI.package = package pkg_descr,+ IPI.license = license pkg_descr,+ IPI.copyright = copyright pkg_descr,+ IPI.maintainer = maintainer pkg_descr,+ IPI.author = author pkg_descr,+ IPI.stability = stability pkg_descr,+ IPI.homepage = homepage pkg_descr,+ IPI.pkgUrl = pkgUrl pkg_descr,+ IPI.description = description pkg_descr,+ IPI.category = category pkg_descr,+ IPI.exposed = True,+ IPI.exposedModules = exposedModules lib,+ IPI.hiddenModules = otherModules bi,+ IPI.importDirs = [if inplace then build_dir else libdir],+ IPI.libraryDirs = (if inplace then build_dir else libdir)+ : 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.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.haddockHTMLs = [haddockDir]+ }++-- -----------------------------------------------------------------------------+-- Unregistration++unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()+unregister pkg_descr lbi regFlags = do+ setupMessage "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+ 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 []+ 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)+ Hugs -> do+ try $ removeDirectoryRecursive (hugsPackageDir pkg_descr lbi)+ 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+ -> 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++-- |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+ -> 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++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++#ifdef DEBUG+hunitTests :: [Test]+hunitTests = []+#endif
+ Distribution/Simple/SrcDist.hs view
@@ -0,0 +1,188 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.SrcDist+-- Copyright : Simon Marlow 2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--++{- Copyright (c) 2003-2004, Simon Marlow+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. -}++-- NOTE: FIX: we don't have a great way of testing this module, since+-- we can't easily look inside a tarball once its created.++module Distribution.Simple.SrcDist (+ sdist+#ifdef DEBUG + ,hunitTests+#endif+ ) where++import Distribution.PackageDescription+ (PackageDescription(..), BuildInfo(..), Executable(..), Library(..),+ setupMessage, libModules)+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 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)++#ifdef DEBUG+import HUnit (Test)+#endif++-- |Create a source distribution. FIX: Calls tar directly (won't work+-- on windows).+sdist :: PackageDescription+ -> SDistFlags -- verbose & 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+ ex <- doesDirectoryExist tmpDir+ when ex (die $ "Source distribution already in place. please move: " ++ tmpDir)+ let targetDir = tmpDir `joinFileName` (nameVersion pkg_descr)+ createDirectoryIfMissing True targetDir+ -- maybe move the library files into place+ maybe (return ()) (\l -> prepareDir verbose targetDir pps (libModules pkg_descr) (libBuildInfo l))+ (library pkg_descr)+ -- move the executables into place+ flip mapM_ (executables pkg_descr) $ \ (Executable _ mainPath exeBi) -> do+ prepareDir verbose targetDir pps [] exeBi+ srcMainFile <- findFile (hsSourceDirs exeBi) mainPath+ copyFileTo verbose targetDir srcMainFile+ flip mapM_ (dataFiles pkg_descr) $ \ file -> do+ let (dir, _) = splitFileName file+ createDirectoryIfMissing True (targetDir `joinFileName` dir)+ copyFileVerbose verbose file (targetDir `joinFileName` file)+ when (not (null (licenseFile pkg_descr))) $+ copyFileTo verbose targetDir (licenseFile pkg_descr)+ flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do+ copyFileTo verbose targetDir fpath+ -- 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 [+ "import Distribution.Simple",+ "main = defaultMainWithHooks defaultUserHooks"]+ -- the description file itself+ descFile <- getCurrentDirectory >>= findPackageDesc+ let targetDescFile = targetDir `joinFileName` 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++ 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+ | "version:" `isPrefixOf` map toLower line =+ trimTrailingSpace line ++ "." ++ show n+ | otherwise = line++ trimTrailingSpace :: String -> String+ trimTrailingSpace = reverse . dropWhile isSpace . reverse++-- |Move the sources into place based on buildInfo+prepareDir :: Int -- ^verbose+ -> FilePath -- ^TargetPrefix+ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)+ -> [String] -- ^Exposed modules+ -> BuildInfo+ -> IO ()+prepareDir verbose 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++copyFileTo :: Int -> FilePath -> FilePath -> IO ()+copyFileTo verbose dir file = do+ let targetFile = dir `joinFileName` file+ createDirectoryIfMissing True (fst (splitFileName targetFile))+ copyFileVerbose verbose file targetFile++------------------------------------------------------------++-- |The file name of the tarball+tarBallName :: PackageDescription -> FilePath+tarBallName p = (nameVersion p) ++ ".tar.gz"++nameVersion :: PackageDescription -> String+nameVersion = showPackageId . package++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++#ifdef DEBUG+hunitTests :: [Test]+hunitTests = []+#endif
+ Distribution/Simple/Utils.hs view
@@ -0,0 +1,517 @@+{-# OPTIONS -cpp -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Utils+-- Copyright : Isaac Jones, Simon Marlow 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Explanation: Misc. Utilities, especially file-related utilities.+-- Stuff used by multiple modules that doesn't fit elsewhere.++{- 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.Utils (+ die,+ dieWithLocation,+ warn,+ rawSystemPath,+ rawSystemVerbose,+ rawSystemExit,+ maybeExit,+ xargs,+ matchesDescFile,+ rawSystemPathExit,+ smartCopySources,+ copyFileVerbose,+ copyDirectoryRecursiveVerbose,+ moduleToFilePath,+ mkLibName,+ mkProfLibName,+ currentDir,+ dirOf,+ dotToSep,+ withTempFile,+ findFile,+ defaultPackageDesc,+ findPackageDesc,+ defaultHookedPackageDesc,+ findHookedPackageDesc,+ distPref,+ haddockPref,+ srcPref,+#ifdef DEBUG+ hunitTests+#endif+ ) where++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604+#if __GLASGOW_HASKELL__ < 603+#include "config.h"+#else+#include "ghcconfig.h"+#endif+#endif++import Distribution.Compat.RawSystem (rawSystem)+import Distribution.Compat.Exception (finally)++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.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))++import Distribution.Compat.Directory+ (copyFile, findExecutable, createDirectoryIfMissing,+ getDirectoryContentsWithoutSpecial)++#ifdef DEBUG+import HUnit ((~:), (~=?), Test(..), assertEqual)+#endif++-- ------------------------------------------------------------------------------- Utils for setup++dieWithLocation :: FilePath -> (Maybe Int) -> String -> IO a+dieWithLocation fname Nothing msg = die (fname ++ ": " ++ msg)+dieWithLocation fname (Just n) msg = die (fname ++ ":" ++ show n ++ ": " ++ msg)++die :: String -> IO a+die msg = do+ hFlush stdout+ pname <- getProgName+ hPutStrLn stderr (pname ++ ": " ++ msg)+ exitWith (ExitFailure 1)++warn :: String -> IO ()+warn msg = do+ hFlush stdout+ pname <- getProgName+ hPutStrLn stderr (pname ++ ": Warning: " ++ 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++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)++maybeExit :: IO ExitCode -> IO ()+maybeExit cmd = do+ res <- cmd+ if res /= ExitSuccess+ then exitWith res + else 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)+ 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++-- | 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 :: Int -> (FilePath -> [String] -> IO ExitCode)+ -> FilePath -> [String] -> [String] -> IO ExitCode+xargs maxSize rawSystem prog 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)++ where chunks len = unfoldr $ \s ->+ if null s then Nothing+ else Just (chunk [] len s)++ chunk acc len [] = (reverse acc,[])+ chunk acc len (s:ss)+ | len' < len = chunk (s:acc) (len-len'-1) ss+ | otherwise = (reverse acc, s:ss)+ where len' = length s++-- ------------------------------------------------------------+-- * File Utilities+-- ------------------------------------------------------------++-- |Get the file path for this particular module. In the IO monad+-- because it looks for the actual file. Might eventually interface+-- with preprocessor libraries in order to correctly locate more+-- filenames.+-- Returns empty list if no such files exist.++moduleToFilePath :: [FilePath] -- ^search locations+ -> String -- ^Module Name+ -> [String] -- ^possible suffixes+ -> IO [FilePath]++moduleToFilePath pref s possibleSuffixes+ = filterM doesFileExist $+ concatMap (searchModuleToPossiblePaths s possibleSuffixes) pref+ where searchModuleToPossiblePaths :: String -> [String] -> FilePath -> [FilePath]+ searchModuleToPossiblePaths s' suffs searchP+ = moduleToPossiblePaths searchP s' suffs++-- |Like 'moduleToFilePath', but return the location and the rest of+-- the path as separate results.+moduleToFilePath2+ :: [FilePath] -- ^search locations+ -> String -- ^Module Name+ -> [String] -- ^possible suffixes+ -> IO [(FilePath, FilePath)] -- ^locations and relative names+moduleToFilePath2 locs mname possibleSuffixes+ = filterM exists $+ [(loc, fname `joinFileExt` ext) | loc <- locs, ext <- possibleSuffixes]+ where+ fname = dotToSep mname+ exists (loc, relname) = doesFileExist (loc `joinFileName` relname)++-- |Get the possible file paths based on this module name.+moduleToPossiblePaths :: FilePath -- ^search prefix+ -> String -- ^module name+ -> [String] -- ^possible suffixes+ -> [FilePath]+moduleToPossiblePaths searchPref s possibleSuffixes =+ let fname = searchPref `joinFileName` (dotToSep s)+ in [fname `joinFileExt` 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]+ 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))++dotToSep :: String -> String+dotToSep = map dts+ where+ dts '.' = pathSeparator+ dts c = c++-- |Copy the source files into the right directory. Looks in the+-- build prefix for files that look like the input modules, based on+-- the input search suffixes. It copies the files into the target+-- directory.++smartCopySources :: Int -- ^verbose+ -> [FilePath] -- ^build prefix (location of objects)+ -> FilePath -- ^Target directory+ -> [String] -- ^Modules+ -> [String] -- ^search suffixes+ -> Bool -- ^Exit if no such modules+ -> Bool -- ^Preserve directory structure+ -> IO ()+smartCopySources verbose srcDirs targetDir sources searchSuffixes exitIfNone preserveDirs+ = do createDirectoryIfMissing True targetDir+ allLocations <- mapM moduleToFPErr sources+ let copies = [(srcDir `joinFileName` name,+ if preserveDirs + then targetDir `joinFileName` srcDir `joinFileName` name+ else targetDir `joinFileName` name) |+ (srcDir, name) <- concat allLocations]+ -- Create parent directories for everything:+ mapM_ (createDirectoryIfMissing True) $ nub $+ [fst (splitFileName targetFile) | (_, targetFile) <- copies]+ -- Put sources into place:+ sequence_ [copyFileVerbose verbose srcFile destFile |+ (srcFile, destFile) <- copies]+ where moduleToFPErr m+ = do p <- moduleToFilePath2 srcDirs m searchSuffixes+ when (null p && exitIfNone)+ (die ("Error: Could not find module: " ++ m+ ++ " with any suffix: " ++ (show searchSuffixes)))+ return p++copyFileVerbose :: Int -> FilePath -> FilePath -> IO ()+copyFileVerbose verbose src dest = do+ when (verbose > 0) $+ putStrLn ("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 ++ "'.")+ 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)+ 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+ getDirectoryContentsWithoutSpecial src >>= mapM_ cp+ in aux srcDir destDir+++++-- | The path name that represents the current directory.+-- In Unix, it's @\".\"@, but this is system-specific.+-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)+currentDir :: FilePath+currentDir = "."++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")++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++-- ------------------------------------------------------------+-- * Finding the description file+-- ------------------------------------------------------------++oldDescFile :: String+oldDescFile = "Setup.description"++cabalExt :: String+cabalExt = "cabal"++buildInfoExt :: String+buildInfoExt = "buildinfo"++matchesDescFile :: FilePath -> Bool+matchesDescFile p = (snd $ splitFileExt p) == cabalExt+ || p == oldDescFile++noDesc :: IO a+noDesc = die $ "No description file found, please create a cabal-formatted description file with the name <pkgname>." ++ cabalExt++multiDesc :: [String] -> IO a+multiDesc l = die $ "Multiple description files found. Please use only one of : "+ ++ show (filter (/= oldDescFile) l)++-- |A list of possibly correct description files. Should be pre-filtered.+descriptionCheck :: [FilePath] -> IO FilePath+descriptionCheck [] = noDesc+descriptionCheck [x]+ | x == oldDescFile+ = do warn $ "The filename \"Setup.description\" is deprecated, please move to <pkgname>." ++ cabalExt+ return x+ | matchesDescFile x = return x+ | otherwise = noDesc+descriptionCheck [x,y]+ | x == oldDescFile+ = do warn $ "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 \""+ ++ x ++ "\""+ return x++ | otherwise = multiDesc [x,y]+descriptionCheck l = multiDesc l++-- |Package description file (/pkgname/@.cabal@)+defaultPackageDesc :: IO FilePath+defaultPackageDesc = getCurrentDirectory >>= findPackageDesc++-- |Find a package description file in the given directory. Looks for+-- @.cabal@ files.+findPackageDesc :: FilePath -- ^Where to look+ -> IO FilePath -- <pkgname>.cabal+findPackageDesc p = do ls <- getDirectoryContents p+ let descs = filter matchesDescFile ls+ descriptionCheck descs++-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)+defaultHookedPackageDesc :: IO (Maybe FilePath)+defaultHookedPackageDesc = getCurrentDirectory >>= findHookedPackageDesc++-- |Find auxiliary package information in the given directory.+-- Looks for @.buildinfo@ files.+findHookedPackageDesc+ :: FilePath -- ^Directory to search+ -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present+findHookedPackageDesc dir = do+ ns <- getDirectoryContents dir+ case [dir `joinFileName` n |+ n <- ns, snd (splitFileExt n) == buildInfoExt] of+ [] -> return Nothing+ [f] -> return (Just f)+ _ -> die ("Multiple files with extension " ++ buildInfoExt)++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++#ifdef DEBUG+hunitTests :: [Test]+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+ 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))+#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+-- or something.+filesWithExtensions :: FilePath -- ^Directory to look in+ -> String -- ^The extension+ -> IO [FilePath] {- ^The file names (not full+ path) of all the files with this+ extension in this directory. -}+filesWithExtensions dir extension + = do allFiles <- getDirectoryContents dir+ return $ filter hasExt allFiles+ where+ hasExt f = snd (splitFileExt f) == extension+#endif
+ Distribution/Version.hs view
@@ -0,0 +1,367 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Version+-- Copyright : Isaac Jones, Simon Marlow 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Versions for packages, based on the 'Version' datatype.++{- Copyright (c) 2003-2004, Isaac Jones+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.Version (+ -- * Package versions+ Version(..),+ showVersion,+ parseVersion,++ -- * Version ranges+ VersionRange(..), + orLaterVersion, orEarlierVersion,+ betweenVersionsInclusive,+ withinRange,+ showVersionRange,+ parseVersionRange,++ -- * Dependencies+ Dependency(..),++#ifdef DEBUG+ hunitTests+#endif+ ) where++#if __HUGS__ || __GLASGOW_HASKELL__ >= 603+import Data.Version ( Version(..), showVersion, parseVersion )+#endif++import Control.Monad ( liftM )++import Distribution.Compat.ReadP++#ifdef DEBUG+import HUnit+#endif++-- -----------------------------------------------------------------------------+-- The Version type++#if ( __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603 ) || __NHC__++-- Code copied from Data.Version in GHC 6.3+ :++-- These #ifdefs are necessary because this code might be compiled as+-- part of ghc/lib/compat, and hence might be compiled by an older version+-- of GHC. In which case, we might need to pick up ReadP from +-- Distribution.Compat.ReadP, because the version in +-- Text.ParserCombinators.ReadP doesn't have all the combinators we need.+#if __GLASGOW_HASKELL__ <= 602 || __NHC__+import Distribution.Compat.ReadP+#else+import Text.ParserCombinators.ReadP+#endif++#if __GLASGOW_HASKELL__ < 602+import Data.Dynamic ( Typeable(..), TyCon, mkTyCon, mkAppTy )+#else+import Data.Typeable ( Typeable )+#endif++import Data.List ( intersperse, sort )+import Data.Char ( isDigit, isAlphaNum )++{- |+A 'Version' represents the version of a software entity. ++An instance of 'Eq' is provided, which implements exact equality+modulo reordering of the tags in the 'versionTags' field.++An instance of 'Ord' is also provided, which gives lexicographic+ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2,+etc.). This is expected to be sufficient for many uses, but note that+you may need to use a more specific ordering for your versioning+scheme. For example, some versioning schemes may include pre-releases+which have tags @"pre1"@, @"pre2"@, and so on, and these would need to+be taken into account when determining ordering. In some cases, date+ordering may be more appropriate, so the application would have to+look for @date@ tags in the 'versionTags' field and compare those.+The bottom line is, don't always assume that 'compare' and other 'Ord'+operations are the right thing for every 'Version'.++Similarly, concrete representations of versions may differ. One+possible concrete representation is provided (see 'showVersion' and+'parseVersion'), but depending on the application a different concrete+representation may be more appropriate.+-}+data Version = + Version { versionBranch :: [Int],+ -- ^ The numeric branch for this version. This reflects the+ -- fact that most software versions are tree-structured; there+ -- is a main trunk which is tagged with versions at various+ -- points (1,2,3...), and the first branch off the trunk after+ -- version 3 is 3.1, the second branch off the trunk after+ -- version 3 is 3.2, and so on. The tree can be branched+ -- arbitrarily, just by adding more digits.+ -- + -- We represent the branch as a list of 'Int', so+ -- version 3.2.1 becomes [3,2,1]. Lexicographic ordering+ -- (i.e. the default instance of 'Ord' for @[Int]@) gives+ -- the natural ordering of branches.++ versionTags :: [String] -- really a bag+ -- ^ A version can be tagged with an arbitrary list of strings.+ -- The interpretation of the list of tags is entirely dependent+ -- on the entity that this version applies to.+ }+ deriving (Read,Show+#if __GLASGOW_HASKELL__ >= 602+ ,Typeable+#endif+ )++#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 602+versionTc :: TyCon+versionTc = mkTyCon "Version"++instance Typeable Version where+ typeOf _ = mkAppTy versionTc []+#endif++instance Eq Version where+ v1 == v2 = versionBranch v1 == versionBranch v2 + && sort (versionTags v1) == sort (versionTags v2)+ -- tags may be in any order++instance Ord Version where+ v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2++-- -----------------------------------------------------------------------------+-- A concrete representation of 'Version'++-- | Provides one possible concrete representation for 'Version'. For+-- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' +-- @= ["tag1","tag2"]@, the output will be @1.2.3-tag1-tag2@.+--+showVersion :: Version -> String+showVersion (Version branch tags)+ = concat (intersperse "." (map show branch)) ++ + concatMap ('-':) tags++-- | A parser for versions in the format produced by 'showVersion'.+--+#if __GLASGOW_HASKELL__ <= 602+parseVersion :: ReadP r Version+#else+parseVersion :: ReadP Version+#endif+parseVersion = do branch <- sepBy1 (liftM read $ munch1 isDigit) (char '.')+ tags <- many (char '-' >> munch1 isAlphaNum)+ return Version{versionBranch=branch, versionTags=tags}++#endif++-- -----------------------------------------------------------------------------+-- Version ranges++-- Todo: maybe move this to Distribution.Package.Version?+-- (package-specific versioning scheme).++data VersionRange+ = AnyVersion+ | ThisVersion Version -- = version+ | LaterVersion Version -- > version (NB. not >=)+ | EarlierVersion Version -- < version+ -- ToDo: are these too general?+ | UnionVersionRanges VersionRange VersionRange+ | IntersectVersionRanges VersionRange VersionRange+ deriving (Show,Read,Eq)++orLaterVersion :: Version -> VersionRange+orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v)++orEarlierVersion :: Version -> VersionRange+orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v)+++betweenVersionsInclusive :: Version -> Version -> VersionRange+betweenVersionsInclusive v1 v2 =+ IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2)++laterVersion :: Version -> Version -> Bool+v1 `laterVersion` v2 = versionBranch v1 > versionBranch v2++earlierVersion :: Version -> Version -> Bool+v1 `earlierVersion` v2 = versionBranch v1 < versionBranch v2++-- |Does this version fall within the given range?+withinRange :: Version -> VersionRange -> Bool+withinRange _ AnyVersion = True+withinRange v1 (ThisVersion v2) = v1 == v2+withinRange v1 (LaterVersion v2) = v1 `laterVersion` v2+withinRange v1 (EarlierVersion v2) = v1 `earlierVersion` v2+withinRange v1 (UnionVersionRanges v2 v3) + = v1 `withinRange` v2 || v1 `withinRange` v3+withinRange v1 (IntersectVersionRanges v2 v3) + = v1 `withinRange` v2 && v1 `withinRange` v3++showVersionRange :: VersionRange -> String+showVersionRange AnyVersion = "-any"+showVersionRange (ThisVersion v) = '=' : '=' : showVersion v+showVersionRange (LaterVersion v) = '>' : showVersion v+showVersionRange (EarlierVersion v) = '<' : showVersion v+showVersionRange (UnionVersionRanges (ThisVersion v1) (LaterVersion v2))+ | v1 == v2 = '>' : '=' : showVersion v1+showVersionRange (UnionVersionRanges (LaterVersion v2) (ThisVersion v1))+ | v1 == v2 = '>' : '=' : showVersion v1+showVersionRange (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2))+ | v1 == v2 = '<' : '=' : showVersion v1+showVersionRange (UnionVersionRanges (EarlierVersion v2) (ThisVersion v1))+ | v1 == v2 = '<' : '=' : showVersion v1+showVersionRange (UnionVersionRanges r1 r2) + = showVersionRange r1 ++ "||" ++ showVersionRange r2+showVersionRange (IntersectVersionRanges r1 r2) + = showVersionRange r1 ++ "&&" ++ showVersionRange r2++-- ------------------------------------------------------------+-- * Package dependencies+-- ------------------------------------------------------------++data Dependency = Dependency String VersionRange+ deriving (Read, Show, Eq)++-- ------------------------------------------------------------+-- * Parsing+-- ------------------------------------------------------------++-- -----------------------------------------------------------+parseVersionRange :: ReadP r VersionRange+parseVersionRange = do+ f1 <- factor+ skipSpaces+ (do+ string "||"+ skipSpaces+ f2 <- factor+ return (UnionVersionRanges f1 f2)+ ++++ do + string "&&"+ skipSpaces+ f2 <- factor+ return (IntersectVersionRanges f1 f2)+ ++++ return f1)+ where + factor = choice ((string "-any" >> return AnyVersion) :+ map parseRangeOp rangeOps)+ parseRangeOp (s,f) = string s >> skipSpaces >> liftM f parseVersion+ rangeOps = [ ("<", EarlierVersion),+ ("<=", orEarlierVersion),+ (">", LaterVersion),+ (">=", orLaterVersion),+ ("==", ThisVersion) ]++#ifdef DEBUG+-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++-- |Simple version parser wrapper+doVersionParse :: String -> Either String Version+doVersionParse input = case results of+ [y] -> Right y+ [] -> Left "No parse"+ _ -> Left "Ambigous parse"+ where results = [ x | (x,"") <- readP_to_S parseVersion input ]++branch1 :: [Int]+branch1 = [1]++branch2 :: [Int]+branch2 = [1,2]++branch3 :: [Int]+branch3 = [1,2,3]++release1 :: Version+release1 = Version{versionBranch=branch1, versionTags=[]}++release2 :: Version+release2 = Version{versionBranch=branch2, versionTags=[]}++release3 :: Version+release3 = Version{versionBranch=branch3, versionTags=[]}++hunitTests :: [Test]+hunitTests+ = [+ "released version 1" ~: "failed"+ ~: (Right $ release1) ~=? doVersionParse "1",+ "released version 3" ~: "failed"+ ~: (Right $ release3) ~=? doVersionParse "1.2.3",++ "range comparison LaterVersion 1" ~: "failed"+ ~: True+ ~=? release3 `withinRange` (LaterVersion release2),+ "range comparison LaterVersion 2" ~: "failed"+ ~: False+ ~=? release2 `withinRange` (LaterVersion release3),+ "range comparison EarlierVersion 1" ~: "failed"+ ~: True+ ~=? release3 `withinRange` (LaterVersion release2),+ "range comparison EarlierVersion 2" ~: "failed"+ ~: False+ ~=? release2 `withinRange` (LaterVersion release3),+ "range comparison orLaterVersion 1" ~: "failed"+ ~: True+ ~=? release3 `withinRange` (orLaterVersion release3),+ "range comparison orLaterVersion 2" ~: "failed"+ ~: True+ ~=? release3 `withinRange` (orLaterVersion release2),+ "range comparison orLaterVersion 3" ~: "failed"+ ~: False+ ~=? release2 `withinRange` (orLaterVersion release3),+ "range comparison orEarlierVersion 1" ~: "failed"+ ~: True+ ~=? release2 `withinRange` (orEarlierVersion release2),+ "range comparison orEarlierVersion 2" ~: "failed"+ ~: True+ ~=? release2 `withinRange` (orEarlierVersion release3),+ "range comparison orEarlierVersion 3" ~: "failed"+ ~: False+ ~=? release3 `withinRange` (orEarlierVersion release2)+ ]+#endif+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Isaac Jones 2003-2005.+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.
+ Language/Haskell/Extension.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.Extension+-- Copyright : Isaac Jones 2003-2004+-- +-- Maintainer : Isaac Jones <ijones@syntaxpolice.org>+-- Stability : alpha+-- Portability : portable+--+-- Haskell language extensions++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Language.Haskell.Extension (+ Extension(..),+ ) where++-- ------------------------------------------------------------+-- * Extension+-- ------------------------------------------------------------++-- NB: if you add a constructor to 'Extension', be sure also to+-- add it to Distribution.Compiler.extensionsTo_X_Flag+-- (where X is each compiler)++-- |This represents language extensions beyond Haskell 98 that are+-- supported by some implementations, usually in some special mode.++data Extension+ = OverlappingInstances+ | UndecidableInstances+ | IncoherentInstances+ | RecursiveDo+ | ParallelListComp+ | MultiParamTypeClasses+ | NoMonomorphismRestriction+ | FunctionalDependencies+ | Rank2Types+ | RankNTypes+ | PolymorphicComponents+ | ExistentialQuantification+ | ScopedTypeVariables+ | ImplicitParams+ | FlexibleContexts+ | FlexibleInstances+ | EmptyDataDecls+ | CPP++ | BangPatterns+ | TypeSynonymInstances+ | TemplateHaskell+ | ForeignFunctionInterface+ | InlinePhase+ | ContextStack+ | Arrows+ | Generics+ | NoImplicitPrelude+ | NamedFieldPuns+ | PatternGuards+ | GeneralizedNewtypeDeriving++ | ExtensibleRecords+ | RestrictedTypeSynonyms+ | HereDocuments+ deriving (Show, Read, Eq)
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell+> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain