diff --git a/Cabal.cabal b/Cabal.cabal new file mode 100644 --- /dev/null +++ b/Cabal.cabal @@ -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 +Maintainer: Isaac Jones +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 diff --git a/Distribution/Compat/Directory.hs b/Distribution/Compat/Directory.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Directory.hs @@ -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 diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Exception.hs @@ -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 diff --git a/Distribution/Compat/FilePath.hs b/Distribution/Compat/FilePath.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/FilePath.hs @@ -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 diff --git a/Distribution/Compat/Map.hs b/Distribution/Compat/Map.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Map.hs @@ -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 diff --git a/Distribution/Compat/RawSystem.hs b/Distribution/Compat/RawSystem.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/RawSystem.hs @@ -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 diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/ReadP.hs @@ -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/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +----------------------------------------------------------------------------- + +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 diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compiler.hs @@ -0,0 +1,210 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Haskell implementations. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.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 diff --git a/Distribution/Extension.hs b/Distribution/Extension.hs new file mode 100644 --- /dev/null +++ b/Distribution/Extension.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Extension +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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(..)) diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs new file mode 100644 --- /dev/null +++ b/Distribution/GetOpt.hs @@ -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 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..." + +-} diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs new file mode 100644 --- /dev/null +++ b/Distribution/InstalledPackageInfo.hs @@ -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 diff --git a/Distribution/License.hs b/Distribution/License.hs new file mode 100644 --- /dev/null +++ b/Distribution/License.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.License +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- The License datatype. For more information about these and other +-- open-source licenses, you may visit . +-- +-- 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) diff --git a/Distribution/Make.hs b/Distribution/Make.hs new file mode 100644 --- /dev/null +++ b/Distribution/Make.hs @@ -0,0 +1,195 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- +-- Maintainer : Isaac Jones +-- 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)) diff --git a/Distribution/Package.hs b/Distribution/Package.hs new file mode 100644 --- /dev/null +++ b/Distribution/Package.hs @@ -0,0 +1,77 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Package +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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} diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription.hs @@ -0,0 +1,896 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Package description and parsing. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription ( + -- * Package descriptions + PackageDescription(..), + 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 diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/ParseUtils.hs @@ -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] diff --git a/Distribution/PreProcess.hs b/Distribution/PreProcess.hs new file mode 100644 --- /dev/null +++ b/Distribution/PreProcess.hs @@ -0,0 +1,308 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PreProcess +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PreProcess (preprocessSources, knownSuffixHandlers, + ppSuffixes, PPSuffixHandler, PreProcessor, + removePreprocessed, removePreprocessedPackage, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit + ) + where + +import Distribution.PreProcess.Unlit(unlit) +import Distribution.PackageDescription (setupMessage, PackageDescription(..), + BuildInfo(..), Executable(..), withExe, + Library(..), withLib, libModules) +import Distribution.Compiler (CompilerFlavor(..), Compiler(..)) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Utils (rawSystemVerbose, + moduleToFilePath, die, dieWithLocation) +import Distribution.Version (Version(..)) +import Control.Monad (unless) +import Data.Maybe (fromMaybe) +import Data.List (nub) +import System.Exit (ExitCode(..)) +import System.Directory (removeFile, getModificationTime) +import System.Info (os, arch) +import Distribution.Compat.FilePath + (splitFileExt, joinFileName, joinFileExt) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler inFile outFile verbose +-- > = do when (verbose > 0) $ +-- > putStrLn (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +type PreProcessor = FilePath -- Location of the source file in need of preprocessing + -> FilePath -- Output filename + -> Int -- verbose + -> IO ExitCode + + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) + +-- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain +-- a Haskell source file for each module. +preprocessSources :: PackageDescription + -> LocalBuildInfo + -> Int -- ^ verbose + -> [PPSuffixHandler] -- ^ preprocessors to try + -> IO () + +preprocessSources pkg_descr lbi verbose handlers = do + withLib pkg_descr () $ \ lib -> do + setupMessage "Preprocessing library" pkg_descr + let bi = libBuildInfo lib + let biHandlers = localHandlers bi + sequence_ [do retVal <- preprocessModule (hsSourceDirs bi) modu + verbose builtinSuffixes biHandlers + unless (retVal == ExitSuccess) + (die $ "got error code while preprocessing: " ++ modu) + | modu <- libModules pkg_descr] + unless (null (executables pkg_descr)) $ + setupMessage "Preprocessing executables for" pkg_descr + withExe pkg_descr $ \ theExe -> do + let bi = buildInfo theExe + let biHandlers = localHandlers bi + sequence_ [do retVal <- preprocessModule (nub $ (hsSourceDirs bi) + ++(maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr))) + modu verbose builtinSuffixes biHandlers + unless (retVal == ExitSuccess) + (die $ "got error code while preprocessing: " ++ modu) + | modu <- otherModules bi] + where hc = compilerFlavor (compiler lbi) + builtinSuffixes + | hc == NHC = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + +-- |Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessModule + :: [FilePath] -- ^source directories + -> String -- ^module name + -> Int -- ^verbose + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> IO ExitCode +preprocessModule searchLoc modu verbose builtinSuffixes handlers = do + bsrcFiles <- moduleToFilePath searchLoc modu builtinSuffixes + psrcFiles <- moduleToFilePath searchLoc modu (map fst handlers) + case psrcFiles of + [] -> case bsrcFiles of + [] -> die ("can't find source for " ++ modu ++ " in " ++ show searchLoc) + _ -> return ExitSuccess + (psrcFile:_) -> do + let (srcStem, ext) = splitFileExt psrcFile + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup ext handlers) + recomp <- case bsrcFiles of + [] -> return True + (bsrcFile:_) -> do + btime <- getModificationTime bsrcFile + ptime <- getModificationTime psrcFile + return (btime < ptime) + if recomp + then pp psrcFile (srcStem `joinFileExt` "hs") verbose + else return ExitSuccess + +removePreprocessedPackage :: PackageDescription + -> FilePath -- ^root of source tree (where to look for hsSources) + -> [String] -- ^suffixes + -> IO () +removePreprocessedPackage pkg_descr r suff + = do withLib pkg_descr () (\lib -> do + let bi = libBuildInfo lib + removePreprocessed (map (joinFileName r) (hsSourceDirs bi)) (libModules pkg_descr) suff) + withExe pkg_descr (\theExe -> do + let bi = buildInfo theExe + removePreprocessed (map (joinFileName r) (hsSourceDirs bi)) (otherModules bi) suff) + +-- |Remove the preprocessed .hs files. (do we need to get some .lhs files too?) +removePreprocessed :: [FilePath] -- ^search Location + -> [String] -- ^Modules + -> [String] -- ^suffixes + -> IO () +removePreprocessed searchLocs mods suffixesIn + = mapM_ removePreprocessedModule mods + where removePreprocessedModule m = do + -- collect related files + fs <- moduleToFilePath searchLocs m otherSuffixes + -- does M.hs also exist? + hs <- moduleToFilePath searchLocs m ["hs"] + unless (null fs) (mapM_ removeFile hs) + otherSuffixes = filter (/= "hs") suffixesIn + +-- ------------------------------------------------------------ +-- * known preprocessors +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard = ppGreenCard' [] + +ppGreenCard' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard' inputArgs bi lbi + = maybe (ppNone "greencard") pp (withGreencard lbi) + where pp greencard inFile outFile verbose + = rawSystemVerbose verbose greencard (["-tffi", "-o" ++ outFile, inFile] ++ inputArgs) + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit inFile outFile verbose = do + contents <- readFile inFile + writeFile outFile (unlit inFile contents) + return ExitSuccess + +ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp' inputArgs bi lbi = + case withCpphs lbi of + Just path -> use_cpphs path + Nothing | compilerFlavor hc == GHC -> use_ghc + _otherwise -> ppNone "cpphs (or GHC)" + where + hc = compiler lbi + + use_cpphs cpphs inFile outFile verbose + = rawSystemVerbose verbose cpphs cpphsArgs + where cpphsArgs = ("-O"++outFile) : inFile : "--noline" : "--strip" + : extraArgs + + extraArgs = sysDefines ++ cppOptions bi lbi ++ inputArgs + + sysDefines = + ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] ++ + ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] + locations = ["BUILD", "HOST"] + + use_ghc inFile outFile verbose + = rawSystemVerbose verbose (compilerPath hc) + (["-E", "-cpp", "-optP-P", "-o", outFile, inFile] ++ extraArgs) + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi + = maybe (ppNone "hsc2hs") pp (withHsc2hs lbi) + where pp n = standardPP n (hcDefines (compiler lbi) + ++ ["-I" ++ dir | dir <- includeDirs bi] + ++ [opt | opt@('-':c:_) <- ccOptions bi, c == 'D' || c == 'I'] + ++ ["--cflag=" ++ opt | opt@('-':'U':_) <- ccOptions bi] + ++ ["--lflag=-L" ++ dir | dir <- extraLibDirs bi] + ++ ["--lflag=-l" ++ lib | lib <- extraLibs bi]) + +ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppC2hs bi lbi + = maybe (ppNone "c2hs") pp (withC2hs lbi) + where pp n = standardPP n (concat [["-C", opt] | opt <- cppOptions bi lbi]) + +cppOptions :: BuildInfo -> LocalBuildInfo -> [String] +cppOptions bi lbi + = hcDefines (compiler lbi) ++ + ["-I" ++ dir | dir <- includeDirs bi] ++ + [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"] + +hcDefines :: Compiler -> [String] +hcDefines Compiler { compilerFlavor=GHC, compilerVersion=version } + = ["-D__GLASGOW_HASKELL__=" ++ versionInt version] +hcDefines Compiler { compilerFlavor=JHC, compilerVersion=version } + = ["-D__JHC__=" ++ versionInt version] +hcDefines Compiler { compilerFlavor=NHC, compilerVersion=version } + = ["-D__NHC__=" ++ versionInt version] +hcDefines Compiler { compilerFlavor=Hugs } + = ["-D__HUGS__"] +hcDefines _ = [] + +versionInt :: Version -> String +versionInt (Version { versionBranch = [] }) = "1" +versionInt (Version { versionBranch = [n] }) = show n +versionInt (Version { versionBranch = n1:n2:_ }) + = show n1 ++ take 2 ('0' : show n2) + +ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHappy _ lbi + = maybe (ppNone "happy") pp (withHappy lbi) + where pp n = standardPP n (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppAlex _ lbi + = maybe (ppNone "alex") pp (withAlex lbi) + where pp n = standardPP n (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags _ = [] + +standardPP :: String -> [String] -> PreProcessor +standardPP eName args inFile outFile verbose + = rawSystemVerbose verbose eName (args ++ ["-o", outFile, inFile]) + +ppNone :: String -> PreProcessor +ppNone name inFile _ _ = + dieWithLocation inFile Nothing $ "no " ++ name ++ " preprocessor available" + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] diff --git a/Distribution/PreProcess/Unlit.hs b/Distribution/PreProcess/Unlit.hs new file mode 100644 --- /dev/null +++ b/Distribution/PreProcess/Unlit.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : Malcolm Wallace +-- Stability : Stable +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" +-- +-- Part of the following code is from +-- /Report on the Programming Language Haskell/, +-- version 1.2, appendix C. + +module Distribution.PreProcess.Unlit(unlit,plain) where + +import Data.Char + +-- exports: + +unlit :: String -> String -> String +unlit file lhs = (unlines . map unclassify . adjacent file (0::Int) Blank + . classify 0) (tolines lhs) + +plain :: String -> String -> String -- no unliteration +plain _ hs = hs +---- + +data Classified = Program String | Blank | Comment + | Include Int String | Pre String + +classify :: Int -> [String] -> [Classified] +classify _ [] = [] +classify _ (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs + where allProg [] = [] -- Should give an error message, but I have no + -- good position information. + allProg (('\\':x'):xs') | x' == "end{code}" = Blank : classify 0 xs' + allProg (x':xs') = Program x':allProg xs' +classify 0 (('>':x):xs) = let (sp,code) = span isSpace x in + Program code : classify (length sp + 1) xs +classify n (('>':x):xs) = Program (drop (n-1) x) : classify n xs +classify _ (('#':x):xs) = + (case words x of + (line:file:_) | all isDigit line -> Include (read line) file + _ -> Pre x + ) : classify 0 xs +classify _ (x:xs) | all isSpace x = Blank:classify 0 xs +classify _ (_:xs) = Comment:classify 0 xs + +unclassify :: Classified -> String +unclassify (Program s) = s +unclassify (Pre s) = '#':s +unclassify (Include i f) = '#':' ':show i ++ ' ':f +unclassify Blank = "" +unclassify Comment = "" + +adjacent :: String -> Int -> Classified -> [Classified] -> [Classified] +adjacent file 0 _ (x :xs) = x: adjacent file 1 x xs + -- force evaluation of line number +adjacent file n (Program _) (Comment :_) = + error (message file n "program" "comment") +adjacent _ _ y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs +adjacent file n y@(Program _) (x@(Pre _) :xs) = x: adjacent file (n+1) y xs +adjacent file n Comment ((Program _) :_) = + error (message file n "comment" "program") +adjacent _ _ y@Comment (x@(Include i f):xs) = x: adjacent f i y xs +adjacent file n y@Comment (x@(Pre _) :xs) = x: adjacent file (n+1) y xs +adjacent _ _ y@Blank (x@(Include i f):xs) = x: adjacent f i y xs +adjacent file n y@Blank (x@(Pre _) :xs) = x: adjacent file (n+1) y xs +adjacent file n _ (x :xs) = x: adjacent file (n+1) x xs +adjacent _ _ _ [] = [] + +message :: (Show a) => String -> a -> String -> String -> String +message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" +message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" +message file n p c = "In file " ++ file ++ " at line " + ++show n++": "++p++ " line before "++c++" line.\n" + + +-- Re-implementation of 'lines', for better efficiency (but decreased +-- laziness). Also, importantly, accepts non-standard DOS and Mac line +-- ending characters. +tolines :: String -> [String] +tolines s' = lines' s' id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + + + +{- +-- A very naive version of unliteration.... +module Unlit(unlit) where +-- This version does not handle \begin{code} & \end{code}, and it is +-- careless with indentation. +unlit = map unlitline + +unlitline ('>' : s) = s +unlitline _ = "" +-} + diff --git a/Distribution/Program.hs b/Distribution/Program.hs new file mode 100644 --- /dev/null +++ b/Distribution/Program.hs @@ -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 diff --git a/Distribution/Setup.hs b/Distribution/Setup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Setup.hs @@ -0,0 +1,808 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Setup +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Explanation: Data types and parser for the standard command-line +-- setup. Will also return commands it doesn't know about. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Setup (--parseArgs, + module Distribution.Compiler, + Action(..), + ConfigFlags(..), emptyConfigFlags, configureArgs, + CopyFlags(..), CopyDest(..), + InstallFlags(..), emptyInstallFlags, + HaddockFlags(..), emptyHaddockFlags, + BuildFlags(..), CleanFlags(..), PFEFlags(..), + RegisterFlags(..), emptyRegisterFlags, + SDistFlags(..), + MaybeUserFlag(..), userOverride, + --optionHelpString, +#ifdef DEBUG + hunitTests, +#endif + parseGlobalArgs, defaultCompilerFlavor, + parseConfigureArgs, parseBuildArgs, parseCleanArgs, + parseHaddockArgs, parseProgramaticaArgs, parseTestArgs, + parseInstallArgs, parseSDistArgs, parseRegisterArgs, + parseUnregisterArgs, parseCopyArgs, + reqPathArg, reqDirArg + ) where + + +-- Misc: +#ifdef DEBUG +import HUnit (Test(..)) +#endif + +import Distribution.Compiler (CompilerFlavor(..), Compiler(..)) +import Distribution.Simple.Utils (die) +import Distribution.Program(ProgramConfiguration(..), + userSpecifyPath, userSpecifyArgs) +import Data.List(find) +import Distribution.Compat.Map (keys) +import Distribution.GetOpt +import Distribution.Compat.FilePath (platformPath) +import System.Exit +import System.Environment + +-- type CommandLineOpts = (Action, +-- [String]) -- The un-parsed remainder + +data Action = ConfigCmd ConfigFlags -- config + | BuildCmd -- build + | CleanCmd -- clean + | CopyCmd CopyDest -- copy (--destdir flag) + | HaddockCmd -- haddock + | ProgramaticaCmd -- pfesetup + | InstallCmd -- install (install-prefix) + | SDistCmd -- sdist + | TestCmd -- test + | RegisterCmd -- register + | UnregisterCmd -- unregister + | HelpCmd -- help +-- | NoCmd -- error case, help case. +-- | TestCmd 1.0? +-- | BDist -- 1.0 +-- | CleanCmd -- clean +-- | NoCmd -- error case? + +-- ------------------------------------------------------------ +-- * Flag-related types +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command +data ConfigFlags = ConfigFlags { + configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run + configHcFlavor :: Maybe CompilerFlavor, + configHcPath :: Maybe FilePath, -- ^given compiler location + configHcPkg :: Maybe FilePath, -- ^given hc-pkg location + configHappy :: Maybe FilePath, -- ^Happy path + configAlex :: Maybe FilePath, -- ^Alex path + configHsc2hs :: Maybe FilePath, -- ^Hsc2hs path + configC2hs :: Maybe FilePath, -- ^C2hs path + configCpphs :: Maybe FilePath, -- ^Cpphs path + configGreencard:: Maybe FilePath, -- ^GreenCard path + configVanillaLib :: Bool, -- ^Enable vanilla library + configProfLib :: Bool, -- ^Enable profiling in the library + configProfExe :: Bool, -- ^Enable profiling in the executables. + configPrefix :: Maybe FilePath, + -- ^installation prefix + configBinDir :: Maybe FilePath, + -- ^installation dir for binaries, + configLibDir :: Maybe FilePath, + -- ^installation dir for object code libraries, + configLibSubDir :: Maybe FilePath, + -- ^subdirectory of libdir in which libs are installed + configLibExecDir :: Maybe FilePath, + -- ^installation dir for program executables, + configDataDir :: Maybe FilePath, + -- ^installation dir for read-only arch-independent data, + configDataSubDir :: Maybe FilePath, + -- ^subdirectory of datadir in which data files are installed + + configVerbose :: Int, -- ^verbosity level + configUser :: Bool, -- ^--user flag? + configGHCiLib :: Bool, -- ^Enable compiling library for GHCi + configSplitObjs :: Bool -- ^Enable -split-objs with GHC + } + +emptyConfigFlags :: ProgramConfiguration -> ConfigFlags +emptyConfigFlags progConf = ConfigFlags { + configPrograms = progConf, + configHcFlavor = defaultCompilerFlavor, + configHcPath = Nothing, + configHcPkg = Nothing, +-- configHaddock = EmptyLocation, + configHappy = Nothing, + configAlex = Nothing, + configHsc2hs = Nothing, + configC2hs = Nothing, + configVanillaLib = True, + configProfLib = False, + configProfExe = False, + configCpphs = Nothing, + configGreencard= Nothing, + configPrefix = Nothing, + configBinDir = Nothing, + configLibDir = Nothing, + configLibSubDir = Nothing, + configLibExecDir = Nothing, + configDataDir = Nothing, + configDataSubDir = Nothing, + configVerbose = 0, + configUser = False, + configGHCiLib = True, + configSplitObjs = False -- takes longer, so turn off by default + } + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbose) +data CopyFlags = CopyFlags {copyDest :: CopyDest + ,copyVerbose :: Int} + +data CopyDest + = NoCopyDest + | CopyTo FilePath + | CopyPrefix FilePath -- DEPRECATED + deriving (Eq, Show) + +data MaybeUserFlag = MaybeUserNone -- ^no --user OR --global flag. + | MaybeUserUser -- ^--user flag + | MaybeUserGlobal -- ^--global flag + +-- |A 'MaybeUserFlag' overrides the default --user setting +userOverride :: MaybeUserFlag -> Bool -> Bool +MaybeUserUser `userOverride` _ = True +MaybeUserGlobal `userOverride` _ = False +_ `userOverride` r = r + +-- | Flags to @install@: (user package, verbose) +data InstallFlags = InstallFlags {installUserFlags::MaybeUserFlag + ,installVerbose :: Int} + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = InstallFlags{ installUserFlags=MaybeUserNone, + installVerbose=0 } + +-- | Flags to @sdist@: (snapshot, verbose) +data SDistFlags = SDistFlags {sDistSnapshot::Bool + ,sDistVerbose:: Int} + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbose) +data RegisterFlags = RegisterFlags {regUser::MaybeUserFlag + ,regGenScript::Bool + ,regInPlace::Bool + ,regWithHcPkg::Maybe FilePath + ,regVerbose::Int} + + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = RegisterFlags { regUser=MaybeUserNone, + regGenScript=False, + regInPlace=False, + regWithHcPkg=Nothing, + regVerbose=0 } + +data HaddockFlags = HaddockFlags {haddockHoogle :: Bool + ,haddockVerbose :: Int} + +emptyHaddockFlags :: HaddockFlags +emptyHaddockFlags = HaddockFlags {haddockHoogle = False, haddockVerbose = 0} + +-- Following only have verbose flags, but for consistency and +-- extensibility we make them into a type. +data BuildFlags = BuildFlags {buildVerbose :: Int} +data CleanFlags = CleanFlags {cleanVerbose :: Int} +data PFEFlags = PFEFlags {pfeVerbose :: Int} + +-- |Most of these flags are for Configure, but InstPrefix is for Copy. +data Flag a = GhcFlag | NhcFlag | HugsFlag | JhcFlag + | WithCompiler FilePath | WithHcPkg FilePath + | WithHappy FilePath | WithAlex FilePath + | WithHsc2hs FilePath | WithC2hs FilePath | WithCpphs FilePath + | WithGreencard FilePath + | WithVanillaLib | WithoutVanillaLib + | WithProfLib | WithoutProfLib + | WithProfExe | WithoutProfExe + | WithGHCiLib | WithoutGHCiLib + | WithSplitObjs | WithoutSplitObjs + + | Prefix FilePath + | BinDir FilePath + | LibDir FilePath + | LibSubDir FilePath + | LibExecDir FilePath + | DataDir FilePath + | DataSubDir FilePath + + | ProgramArgs String String -- program name, arguments + | WithProgram String FilePath -- program name, location + + -- For install, register, and unregister: + | UserFlag | GlobalFlag + -- for register & unregister + | GenScriptFlag + | InPlaceFlag + -- For copy: + | InstPrefix FilePath + | DestDir FilePath + -- For sdist: + | Snapshot + -- For haddock: + | HaddockHoogle + -- For everyone: + | HelpFlag + | Verbose Int +-- | Version? + | Lift a + deriving (Show, Eq) + + +-- ------------------------------------------------------------ +-- * Mostly parsing functions +-- ------------------------------------------------------------ + +defaultCompilerFlavor :: Maybe CompilerFlavor +defaultCompilerFlavor = +#if defined(__GLASGOW_HASKELL__) + Just GHC +#elif defined(__NHC__) + Just NHC +#elif defined(__JHC__) + Just JHC +#elif defined(__HUGS__) + Just Hugs +#else + Nothing +#endif + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: ConfigFlags -> [String] +configureArgs flags + = hc_flag ++ + optFlag "with-hc-pkg" configHcPkg ++ + optFlag "prefix" configPrefix ++ + optFlag "bindir" configBinDir ++ + optFlag "libdir" configLibDir ++ + optFlag "libexecdir" configLibExecDir ++ + optFlag "datadir" configDataDir + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Just hc_path) -> ["--with-hc=" ++ hc_path] + (Just hc, Nothing) -> ["--with-hc=" ++ showHC hc] + (Nothing,Nothing) -> [] + optFlag name config_field = case config_field flags of + Just p -> ["--" ++ name ++ "=" ++ p] + Nothing -> [] + + showHC GHC = "ghc" + showHC NHC = "nhc98" + showHC JHC = "jhc" + showHC Hugs = "hugs" + showHC c = "unknown compiler: " ++ (show c) + + +cmd_help :: OptDescr (Flag a) +cmd_help = Option "h?" ["help"] (NoArg HelpFlag) "Show this help text" + +cmd_verbose :: OptDescr (Flag a) +cmd_verbose = Option "v" ["verbose"] (OptArg verboseFlag "n") "Control verbosity (n is 0--5, normal verbosity level is 1, -v alone is equivalent to -v3)" + where + verboseFlag mb_s = Verbose (maybe 3 read mb_s) + +cmd_with_hc_pkg :: OptDescr (Flag a) +cmd_with_hc_pkg = Option "" ["with-hc-pkg"] (reqPathArg WithHcPkg) + "give the path to the package tool" + +-- Do we have any other interesting global flags? +globalOptions :: [OptDescr (Flag a)] +globalOptions = [ + cmd_help + ] + +liftCustomOpts :: [OptDescr a] -> [OptDescr (Flag a)] +liftCustomOpts flags = [ Option shopt lopt (f adesc) help + | Option shopt lopt adesc help <- flags ] + where f (NoArg x) = NoArg (Lift x) + f (ReqArg g s) = ReqArg (Lift . g) s + f (OptArg g s) = OptArg (Lift . g) s + +data Cmd a = Cmd { + cmdName :: String, + cmdHelp :: String, -- Short description + cmdDescription :: String, -- Long description + cmdOptions :: [OptDescr (Flag a)], + cmdAction :: Action + } + +commandList :: ProgramConfiguration -> [Cmd a] +commandList progConf = [(configureCmd progConf), buildCmd, cleanCmd, installCmd, + copyCmd, sdistCmd, testCmd, haddockCmd, programaticaCmd, + registerCmd, unregisterCmd] + +lookupCommand :: String -> [Cmd a] -> Maybe (Cmd a) +lookupCommand name = find ((==name) . cmdName) + +printGlobalHelp :: ProgramConfiguration -> IO () +printGlobalHelp progConf = + do pname <- getProgName + let syntax_line = "Usage: " ++ pname ++ " [GLOBAL FLAGS]\n or: " ++ pname ++ " COMMAND [FLAGS]\n\nGlobal flags:" + putStrLn (usageInfo syntax_line globalOptions) + putStrLn "Commands:" + let maxlen = maximum [ length (cmdName cmd) | cmd <- (commandList progConf) ] + sequence_ [ do putStr " " + putStr (align maxlen (cmdName cmd)) + putStr " " + putStrLn (cmdHelp cmd) + | cmd <- (commandList progConf) ] + putStrLn $ "\nFor more information about a command, try '" ++ pname ++ " COMMAND --help'." + where align n str = str ++ replicate (n - length str) ' ' + +printCmdHelp :: Cmd a -> [OptDescr a] -> IO () +printCmdHelp cmd opts = do pname <- getProgName + let syntax_line = "Usage: " ++ pname ++ " " ++ cmdName cmd ++ " [FLAGS]\n\nFlags for " ++ cmdName cmd ++ ":" + putStrLn (usageInfo syntax_line (cmdOptions cmd ++ liftCustomOpts opts)) + putStr (cmdDescription cmd) + +getCmdOpt :: Cmd a -> [OptDescr a] -> [String] -> ([Flag a], [String], [String]) +getCmdOpt cmd opts s = let (a,_,c,d) = getOpt' Permute (cmdOptions cmd ++ liftCustomOpts opts) s + in (a,c,d) + +-- We don't want to use elem, because that imposes Eq a +hasHelpFlag :: [Flag a] -> Bool +hasHelpFlag flags = not . null $ [ () | HelpFlag <- flags ] + +parseGlobalArgs :: ProgramConfiguration -> [String] -> IO (Action,[String]) +parseGlobalArgs progConf args = + case getOpt' RequireOrder globalOptions args of + (flags, _, _, []) | hasHelpFlag flags -> do + (printGlobalHelp progConf) + exitWith ExitSuccess + (_, cname:cargs, extra_args, []) -> do + case lookupCommand cname (commandList progConf) of + Just cmd -> return (cmdAction cmd, extra_args ++ cargs) + Nothing -> die $ "Unrecognised command: " ++ cname ++ " (try --help)" + (_, [], _, []) -> die $ "No command given (try --help)" + (_, _, _, errs) -> putErrors errs + +configureCmd :: ProgramConfiguration -> Cmd a +configureCmd progConf = Cmd { + cmdName = "configure", + cmdHelp = "Prepare to build the package.", + cmdDescription = "", -- This can be a multi-line description + cmdOptions = [cmd_help, cmd_verbose, + Option "g" ["ghc"] (NoArg GhcFlag) "compile with GHC", + Option "n" ["nhc"] (NoArg NhcFlag) "compile with NHC", + Option "" ["jhc"] (NoArg JhcFlag) "compile with JHC", + Option "" ["hugs"] (NoArg HugsFlag) "compile with hugs", + Option "w" ["with-compiler"] (reqPathArg WithCompiler) + "give the path to a particular compiler", + cmd_with_hc_pkg, + Option "" ["prefix"] (reqDirArg Prefix) + "bake this prefix in preparation of installation", + Option "" ["bindir"] (reqDirArg BinDir) + "installation directory for executables", + Option "" ["libdir"] (reqDirArg LibDir) + "installation directory for libraries", + Option "" ["libsubdir"] (reqDirArg LibSubDir) + "subdirectory of libdir in which libs are installed", + Option "" ["libexecdir"] (reqDirArg LibExecDir) + "installation directory for program executables", + Option "" ["datadir"] (reqDirArg DataDir) + "installation directory for read-only data", + Option "" ["datasubdir"] (reqDirArg DataSubDir) + "subdirectory of datadir in which data files are installed", + Option "" ["with-happy"] (reqPathArg WithHappy) + "give the path to happy", + Option "" ["with-alex"] (reqPathArg WithAlex) + "give the path to alex", + Option "" ["with-hsc2hs"] (reqPathArg WithHsc2hs) + "give the path to hsc2hs", + Option "" ["with-c2hs"] (reqPathArg WithC2hs) + "give the path to c2hs", + Option "" ["with-cpphs"] (reqPathArg WithCpphs) + "give the path to cpphs", + Option "" ["with-greencard"] (reqPathArg WithGreencard) + "give the path to greencard", + Option "" ["enable-library-vanilla"] (NoArg WithVanillaLib) + "Enable vanilla libraries", + Option "" ["disable-library-vanilla"] (NoArg WithoutVanillaLib) + "Disable vanilla libraries", + Option "p" ["enable-library-profiling"] (NoArg WithProfLib) + "Enable library profiling", + Option "" ["disable-library-profiling"] (NoArg WithoutProfLib) + "Disable library profiling", + Option "" ["enable-executable-profiling"] (NoArg WithProfExe) + "Enable executable profiling", + Option "" ["disable-executable-profiling"] (NoArg WithoutProfExe) + "Disable executable profiling", + Option "" ["enable-library-for-ghci"] (NoArg WithGHCiLib) + "compile library for use with GHCi", + Option "" ["disable-library-for-ghci"] (NoArg WithoutGHCiLib) + "do not compile libraries for GHCi", + Option "" ["enable-split-objs"] (NoArg WithSplitObjs) + "split library into smaller objects to reduce binary sizes (GHC 6.6+)", + Option "" ["disable-split-objs"] (NoArg WithoutSplitObjs) + "split library into smaller objects to reduce binary sizes (GHC 6.6+)", + Option "" ["user"] (NoArg UserFlag) + "allow dependencies to be satisfied from the user package database. also implies install --user", + Option "" ["global"] (NoArg GlobalFlag) + "(default) dependencies must be satisfied from the global package database" + ] +{- + FIX: Instead of using ++ here, we might add extra arguments. That + way, we can condense the help out put to something like + --with-{haddock,happy,alex,etc} + + FIX: shouldn't use default. Look in hooks?. +-} + ++ (withProgramOptions progConf) + ++ (programArgsOptions progConf), + cmdAction = ConfigCmd (emptyConfigFlags progConf) + } + +programArgsOptions :: ProgramConfiguration -> [OptDescr (Flag a)] +programArgsOptions (ProgramConfiguration conf) = map f (keys conf) + where f name = Option "" [name ++ "-args"] (reqPathArg (ProgramArgs name)) + ("give the args to " ++ name) + +withProgramOptions :: ProgramConfiguration -> [OptDescr (Flag a)] +withProgramOptions (ProgramConfiguration conf) = map f (keys conf) + where f name = Option "" ["with-" ++ name] (reqPathArg (WithProgram name)) + ("give the path to " ++ name) + +reqPathArg :: (FilePath -> a) -> ArgDescr a +reqPathArg constr = ReqArg (constr . platformPath) "PATH" + +reqDirArg :: (FilePath -> a) -> ArgDescr a +reqDirArg constr = ReqArg (constr . platformPath) "DIR" + +parseConfigureArgs :: ProgramConfiguration -> ConfigFlags -> [String] -> [OptDescr a] -> + IO (ConfigFlags, [a], [String]) +parseConfigureArgs progConf = parseArgs (configureCmd progConf) updateCfg + where updateCfg t GhcFlag = t { configHcFlavor = Just GHC } + updateCfg t NhcFlag = t { configHcFlavor = Just NHC } + updateCfg t JhcFlag = t { configHcFlavor = Just JHC } + updateCfg t HugsFlag = t { configHcFlavor = Just Hugs } + updateCfg t (WithCompiler path) = t { configHcPath = Just path } + updateCfg t (WithHcPkg path) = t { configHcPkg = Just path } + updateCfg t (WithHappy path) = t { configHappy = Just path } + updateCfg t (WithAlex path) = t { configAlex = Just path } + updateCfg t (WithHsc2hs path) = t { configHsc2hs = Just path } + updateCfg t (WithC2hs path) = t { configC2hs = Just path } + updateCfg t (WithCpphs path) = t { configCpphs = Just path } + updateCfg t (WithGreencard path) = t { configGreencard= Just path } + updateCfg t (ProgramArgs name args) = t { configPrograms = (userSpecifyArgs + name + args (configPrograms t))} + updateCfg t (WithProgram name path) = t { configPrograms = (userSpecifyPath + name + path (configPrograms t))} + updateCfg t WithVanillaLib = t { configVanillaLib = True } + updateCfg t WithoutVanillaLib = t { configVanillaLib = False, configGHCiLib = False } + updateCfg t WithProfLib = t { configProfLib = True } + updateCfg t WithoutProfLib = t { configProfLib = False } + updateCfg t WithProfExe = t { configProfExe = True } + updateCfg t WithoutProfExe = t { configProfExe = False } + updateCfg t WithGHCiLib = t { configGHCiLib = True } + updateCfg t WithoutGHCiLib = t { configGHCiLib = False } + updateCfg t (Prefix path) = t { configPrefix = Just path } + updateCfg t (BinDir path) = t { configBinDir = Just path } + updateCfg t (LibDir path) = t { configLibDir = Just path } + updateCfg t (LibSubDir path) = t { configLibSubDir= Just path } + updateCfg t (LibExecDir path) = t { configLibExecDir = Just path } + updateCfg t (DataDir path) = t { configDataDir = Just path } + updateCfg t (DataSubDir path) = t { configDataSubDir = Just path } + updateCfg t (Verbose n) = t { configVerbose = n } + updateCfg t UserFlag = t { configUser = True } + updateCfg t GlobalFlag = t { configUser = False } + updateCfg t WithSplitObjs = t { configSplitObjs = True } + updateCfg t WithoutSplitObjs = t { configSplitObjs = False } + updateCfg t (Lift _) = t + updateCfg t _ = error $ "Unexpected flag!" + +buildCmd :: Cmd a +buildCmd = Cmd { + cmdName = "build", + cmdHelp = "Make this package ready for installation.", + cmdDescription = "", -- This can be a multi-line description + cmdOptions = [cmd_help, cmd_verbose], + cmdAction = BuildCmd + } + +parseBuildArgs :: [String] -> [OptDescr a] -> IO (BuildFlags, [a], [String]) +parseBuildArgs = parseNoArgs buildCmd BuildFlags + +haddockCmd :: Cmd a +haddockCmd = Cmd { + cmdName = "haddock", + cmdHelp = "Generate Haddock HTML code from Exposed-Modules.", + cmdDescription = "Requires cpphs and haddock.", + cmdOptions = [cmd_help, cmd_verbose, + Option "" ["hoogle"] (NoArg HaddockHoogle) "Generate a hoogle database"], + cmdAction = HaddockCmd + } + +parseHaddockArgs :: HaddockFlags -> [String] -> [OptDescr a] -> IO (HaddockFlags, [a], [String]) +parseHaddockArgs = parseArgs haddockCmd updateCfg + where updateCfg (HaddockFlags hoogle verbose) fl = case fl of + HaddockHoogle -> HaddockFlags True verbose + Verbose n -> HaddockFlags hoogle n + _ -> error "Unexpected flag!" + +programaticaCmd :: Cmd a +programaticaCmd = Cmd { + cmdName = "pfe", + cmdHelp = "Generate Programatica Project.", + cmdDescription = "", + cmdOptions = [cmd_help, cmd_verbose], + cmdAction = ProgramaticaCmd + } + +parseProgramaticaArgs :: [String] -> [OptDescr a] -> IO (PFEFlags, [a], [String]) +parseProgramaticaArgs = parseNoArgs programaticaCmd PFEFlags + +cleanCmd :: Cmd a +cleanCmd = Cmd { + cmdName = "clean", + cmdHelp = "Clean up after a build.", + cmdDescription = "Removes .hi, .o, preprocessed sources, etc.\n", -- Multi-line! + cmdOptions = [cmd_help, cmd_verbose], + cmdAction = CleanCmd + } + +parseCleanArgs :: [String] -> [OptDescr a] -> IO (CleanFlags, [a], [String]) +parseCleanArgs = parseNoArgs cleanCmd CleanFlags + +installCmd :: Cmd a +installCmd = Cmd { + cmdName = "install", + cmdHelp = "Copy the files into the install locations. Run register.", + cmdDescription = "Unlike the copy command, install calls the register command.\nIf you want to install into a location that is not what was\nspecified in the configure step, use the copy command.\n", + cmdOptions = [cmd_help, cmd_verbose, + Option "" ["install-prefix"] (reqDirArg InstPrefix) + "[DEPRECATED, use copy]", + Option "" ["user"] (NoArg UserFlag) + "upon registration, register this package in the user's local package database", + Option "" ["global"] (NoArg GlobalFlag) + "(default; override with configure) upon registration, register this package in the system-wide package database" + ], + cmdAction = InstallCmd + } + +copyCmd :: Cmd a +copyCmd = Cmd { + cmdName = "copy", + cmdHelp = "Copy the files into the install locations.", + cmdDescription = "Does not call register, and allows a prefix at install time\nWithout the --destdir flag, configure determines location.\n", + cmdOptions = [cmd_help, cmd_verbose, + Option "" ["destdir"] (reqDirArg DestDir) + "directory to copy files to, prepended to installation directories", + Option "" ["copy-prefix"] (reqDirArg InstPrefix) + "[DEPRECATED, directory to copy files to instead of prefix]" + ], + cmdAction = CopyCmd NoCopyDest + } + +parseCopyArgs :: CopyFlags -> [String] -> [OptDescr a] -> + IO (CopyFlags, [a], [String]) +parseCopyArgs = parseArgs copyCmd updateCfg + where updateCfg (CopyFlags copydest verbose) fl = case fl of + InstPrefix path -> (CopyFlags (CopyPrefix path) verbose) + DestDir path -> (CopyFlags (CopyTo path) verbose) + Verbose n -> (CopyFlags copydest n) + _ -> error $ "Unexpected flag!" + + +parseInstallArgs :: InstallFlags -> [String] -> [OptDescr a] -> + IO (InstallFlags, [a], [String]) +parseInstallArgs = parseArgs installCmd updateCfg + where updateCfg (InstallFlags uFlag verbose) fl = case fl of + InstPrefix _ -> error "--install-prefix is obsolete. Use copy command instead." + UserFlag -> (InstallFlags MaybeUserUser verbose) + GlobalFlag -> (InstallFlags MaybeUserGlobal verbose) + Verbose n -> (InstallFlags uFlag n) + _ -> error $ "Unexpected flag!" + +sdistCmd :: Cmd a +sdistCmd = Cmd { + cmdName = "sdist", + cmdHelp = "Generate a source distribution file (.tar.gz or .zip).", + cmdDescription = "", -- This can be a multi-line description + cmdOptions = [cmd_help,cmd_verbose, + Option "" ["snapshot"] (NoArg Snapshot) + "Produce a snapshot source distribution" + ], + cmdAction = SDistCmd + } + +parseSDistArgs :: [String] -> [OptDescr a] -> IO (SDistFlags, [a], [String]) +parseSDistArgs = parseArgs sdistCmd updateCfg (SDistFlags False 0) + where updateCfg (SDistFlags snapshot verbose) fl = case fl of + Snapshot -> (SDistFlags True verbose) + Verbose n -> (SDistFlags snapshot n) + _ -> error $ "Unexpected flag!" + +testCmd :: Cmd a +testCmd = Cmd { + cmdName = "test", + cmdHelp = "Run the test suite, if any (configure with UserHooks).", + cmdDescription = "", -- This can be a multi-line description + cmdOptions = [cmd_help,cmd_verbose], + cmdAction = TestCmd + } + +parseTestArgs :: [String] -> [OptDescr a] -> IO (Int, [a], [String]) +parseTestArgs = parseNoArgs testCmd id + +registerCmd :: Cmd a +registerCmd = Cmd { + cmdName = "register", + cmdHelp = "Register this package with the compiler.", + cmdDescription = "", -- This can be a multi-line description + cmdOptions = [cmd_help, cmd_verbose, + Option "" ["user"] (NoArg UserFlag) + "upon registration, register this package in the user's local package database", + Option "" ["global"] (NoArg GlobalFlag) + "(default) upon registration, register this package in the system-wide package database", + Option "" ["inplace"] (NoArg InPlaceFlag) + "register the package in the build location, so it can be used without being installed", + Option "" ["gen-script"] (NoArg GenScriptFlag) + "Instead of performing the register command, generate a script to register later", + cmd_with_hc_pkg + ], + cmdAction = RegisterCmd + } + +parseRegisterArgs :: RegisterFlags -> [String] -> [OptDescr a] -> + IO (RegisterFlags, [a], [String]) +parseRegisterArgs = parseArgs registerCmd updateCfg + where updateCfg reg fl = case fl of + UserFlag -> reg { regUser=MaybeUserUser } + GlobalFlag -> reg { regUser=MaybeUserGlobal } + Verbose n -> reg { regVerbose=n } + GenScriptFlag -> reg { regGenScript=True } + InPlaceFlag -> reg { regInPlace=True } + WithHcPkg f -> reg { regWithHcPkg=Just f } + _ -> error $ "Unexpected flag!" + +unregisterCmd :: Cmd a +unregisterCmd = Cmd { + cmdName = "unregister", + cmdHelp = "Unregister this package with the compiler.", + cmdDescription = "", -- This can be a multi-line description + cmdOptions = [cmd_help, cmd_verbose, + Option "" ["user"] (NoArg UserFlag) + "unregister this package in the user's local package database", + Option "" ["global"] (NoArg GlobalFlag) + "(default) unregister this package in the system-wide package database", + Option "" ["gen-script"] (NoArg GenScriptFlag) + "Instead of performing the unregister command, generate a script to unregister later" + + ], + cmdAction = UnregisterCmd + } + +parseUnregisterArgs :: RegisterFlags -> [String] -> [OptDescr a] -> + IO (RegisterFlags, [a], [String]) +parseUnregisterArgs = parseRegisterArgs + +-- |Helper function for commands with no arguments except for verbose +-- and help. + +parseNoArgs :: (Cmd a) + -> (Int -> b) -- Constructor to make this type. + -> [String] -> [OptDescr a]-> IO (b, [a], [String]) +parseNoArgs cmd c = parseArgs cmd updateCfg (c 0) + where + updateCfg _ (Verbose n) = c n + updateCfg _ _ = error "Unexpected flag!" + +-- |Helper function for commands with more options. + +parseArgs :: Cmd a -> (cfg -> Flag a -> cfg) -> cfg -> + [String] -> [OptDescr a] -> IO (cfg, [a], [String]) +parseArgs cmd updateCfg cfg args customOpts = + case getCmdOpt cmd customOpts args of + (flags, _, []) | hasHelpFlag flags -> do + printCmdHelp cmd customOpts + exitWith ExitSuccess + (flags, args', []) -> + let flags' = filter (not.isLift) flags in + return (foldl updateCfg cfg flags', unliftFlags flags, args') + (_, _, errs) -> putErrors errs + where + isLift (Lift _) = True + isLift _ = False + unliftFlags :: [Flag a] -> [a] + unliftFlags flags = [ fl | Lift fl <- flags ] + +putErrors :: [String] -> IO a +putErrors errs = die $ "Errors:" ++ concat ['\n':err | err <- errs] + + +#ifdef DEBUG +hunitTests :: [Test] +hunitTests = [] +-- The test cases kinda have to be rewritten from the ground up... :/ +--hunitTests = +-- let m = [("ghc", GHC), ("nhc", NHC), ("hugs", Hugs)] +-- (flags, commands', unkFlags, ers) +-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] +-- in [TestLabel "very basic option parsing" $ TestList [ +-- "getOpt flags" ~: "failed" ~: +-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, +-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] +-- ~=? flags, +-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', +-- "getOpt unknown opts" ~: "failed" ~: +-- ["--unknown1", "--unknown2"] ~=? unkFlags, +-- "getOpt errors" ~: "failed" ~: [] ~=? ers], +-- +-- TestLabel "test location of various compilers" $ TestList +-- ["configure parsing for prefix and compiler flag" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "find the package tool" $ TestList +-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, +-- "--with-compiler=/foo/comp", "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "simpler commands" $ TestList +-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) +-- | (flag, flagCmd) <- [("build", BuildCmd), +-- ("install", InstallCmd Nothing False), +-- ("sdist", SDistCmd), +-- ("register", RegisterCmd False)] +-- ] +-- ] +#endif + + +{- Testing ideas: + * IO to look for hugs and hugs-pkg (which hugs, etc) + * quickCheck to test permutations of arguments + * what other options can we over-ride with a command-line flag? +-} + diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple.hs @@ -0,0 +1,692 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Explanation: Simple build system; basically the interface for +-- Distribution.Simple.\* modules. When given the parsed command-line +-- args and package information, is able to perform basic commands +-- like configure, build, install, register, etc. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple ( + 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 diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Build.hs @@ -0,0 +1,282 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- 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_.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_.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 diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Configure.hs @@ -0,0 +1,486 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC.hs @@ -0,0 +1,435 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple/GHCPackageConfig.hs b/Distribution/Simple/GHCPackageConfig.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHCPackageConfig.hs @@ -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))) diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Hugs.hs @@ -0,0 +1,355 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hugs +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : Isaac Jones +-- 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 /lib/hugs/packages/ +-- (i.e. /lib/hugs/packages/ on the target system). +-- Each executable goes in /lib/hugs/programs/ +-- (i.e. /lib/hugs/programs/ on the target system) +-- with a script /bin/ pointing at +-- /lib/hugs/programs/ +install + :: Int -- ^verbose + -> FilePath -- ^Library install location + -> FilePath -- ^Program install location + -> FilePath -- ^Executable install location + -> FilePath -- ^Program location on target system + -> FilePath -- ^Build location + -> 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) diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Install.hs @@ -0,0 +1,133 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/JHC.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.JHC +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : Isaac Jones +-- 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) diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -0,0 +1,324 @@ +{-# OPTIONS -cpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/NHC.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.NHC +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : Isaac Jones +-- 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)) + diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Register.hs @@ -0,0 +1,379 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/SrcDist.hs @@ -0,0 +1,188 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- +-- Maintainer : Isaac Jones +-- 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 diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Utils.hs @@ -0,0 +1,517 @@ +{-# OPTIONS -cpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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 ." ++ 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 ." ++ 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 -- .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 diff --git a/Distribution/Version.hs b/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Version.hs @@ -0,0 +1,367 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Extension.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Extension +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- 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) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain